|
|
加入QQ群
参与讨论和学习
或扫描二维码加入
'定义solidwork
'这个宏是获取最大外形尺寸的:
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim Height As Variant
Dim Width As Variant
Dim Length As Variant
Dim Corners As Variant
Dim retval As Boolean
Dim UserUnits As Variant
Const swDocPart = 1
Const swDocASSEMBLY = 2
'Enum swLengthUnit_e
Const swMM = 0
Const swCM = 1
Const swMETER = 2
Const swINCHES = 3
Const swFEET = 4
Const swFEETINCHES = 5
Const swANGSTROM = 6
Const swNANOMETER = 7
Const swMICRON = 8
Const swMIL = 9
Const swUIN = 10
'Enum swFractionDisplay_e
Const swNONE = 0
Const swDECIMAL = 1
Const swFRACTION = 2
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim swModel As SldWorks.ModelDoc2
Dim StockSize As String
'Dim swApp As Object
'Dim Part As Object
Dim SelMgr As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Feature As Object
Dim a As Integer
Dim b As String
Dim m As String
Dim e As String
Dim k As String
Dim t As String
Dim c As String
Dim j As Integer
Dim strmat As String
Dim tempvalue As String
Sub Main()
'link solidworks
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
swApp.ActiveDoc.ActiveView.FrameState = 1
'设定变量
c = swApp.ActiveDoc.GetTitle() '零件名
strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
blnretval = Part.DeleteCustomInfo2("", "代号")
blnretval = Part.DeleteCustomInfo2("", "名称")
blnretval = Part.DeleteCustomInfo2("", "材料")
a = InStr(c, " ") - 1 '重点：分隔标识符，这里是一个空格
If a > 0 Then
k = Left(c, a)
t = Left(LTrim(e), 3)
If t = "GBT" Then
e = "GB/T" + Mid(k, 4)
Else
e = k
End If
b = Mid(c, a + 2)
t = Right(c, 7)
If t = ".SLDPRT" Or t = ".SLDASM" Then
j = Len(b) - 7
Else
j = Len(b)
End If
m = Left(b, j)
End If
blnretval = Part.AddCustomInfo3("", "代号", swCustomInfoText, e) '代号
blnretval = Part.AddCustomInfo3("", "名称", swCustomInfoText, m) '名称
blnretval = Part.AddCustomInfo3("", "表面处理", swCustomInfoText, " ")
'End Sub'停此句
'Sub Main()'停此句
Dim arr(1 To 3) As Double
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
If Part Is Nothing Then ' Did we get anything?
MsgBox "You need to have a part or assy open at this point." & Chr$(13) & Chr$(10) _
& Chr$(10) & "Open one and try again."
Exit Sub
End If
If (Part.GetType = swDocPart) Then
Corners = Part.GetPartBox(True) ' True comes back as system units - meters
ElseIf Part.GetType = swDocASSEMBLY Then ' Units will come back as meters
Corners = Part.GetBox(0)
Else
MsgBox "This macro is only useful with a part or assy." & Chr$(13) & Chr$(10) & "Open one of those and try again."
Exit Sub
End If
UserUnits = Part.GetUnits()
Select Case Part.GetUnits(0)
Case swMM
ConvFactor = 1 * 1000
Case swCM
ConvFactor = 1 * 100
Case swMETER
ConvFactor = 1
Case swINCHES
ConvFactor = 1 / 0.0254
Case swFEET
ConvFactor = 1 / (0.0254 * 12)
Case swFEETINCHES
ConvFactor = 1 / 0.0254 ' Pass inches through
Case swANGSTROM
ConvFactor = 10000000000#
Case swNANOMETER
ConvFactor = 1000000000
Case swMICRON
ConvFactor = 1000000
Case swMIL
ConvFactor = (1 / 0.0254) * 1000
Case swUIN
ConvFactor = (1 / 0.0254) * 1000000
End Select
Height = Round((Abs(Corners(4) - Corners(1)) * ConvFactor), UserUnits(3)) ' Z axis
Width = Round((Abs(Corners(5) - Corners(2)) * ConvFactor), UserUnits(3)) ' Y axis
Length = Round((Abs(Corners(3) - Corners(0)) * ConvFactor), UserUnits(3)) ' X axis
' Check for either (Feet-Inches OR Inches) AND fractions. If so, return Ft-In
If (UserUnits(0) = 5 Or UserUnits(0) = 3) And UserUnits(1) = 2 Then
Height = DecimalToFeetInches(Height, Val(UserUnits(2)))
Width = DecimalToFeetInches(Width, Val(UserUnits(2)))
Length = DecimalToFeetInches(Length, Val(UserUnits(2)))
End If
Call SortDimensions
End Sub
Function DecimalToFeetInches(DecimalLength As Variant, Denominator As Integer) As String
' converts decimal inches to feet/inches/fractions
Dim intFeet As Integer
Dim intInches As Integer
Dim intFractions As Integer
Dim FractToDecimal As Double
Dim remainder As Double
Dim tmpVal As Double
' compute whole feet
intFeet = Int(DecimalLength / 12)
remainder = DecimalLength - (intFeet * 12)
tmpVal = CDbl(Denominator)
intInches = Int(remainder)
remainder = remainder - intInches
If Not (remainder = 0) Then
If Not (Denominator = 0) Then
FractToDecimal = 1 / tmpVal
If FractToDecimal > 0 Then
intFractions = Int(remainder / FractToDecimal)
If (remainder / FractToDecimal) - intFractions > 0 Then
intFractions = intFractions + 1
End If
End If
End If
End If
Call FractUp(intFeet, intInches, intFractions, Denominator) ' Simplify up & down
DecimalToFeetInches = LTrim$(Str$(intFeet)) & "'-"
DecimalToFeetInches = DecimalToFeetInches & LTrim$(Str$(intInches))
If intFractions > 0 Then
DecimalToFeetInches = DecimalToFeetInches & " "
DecimalToFeetInches = DecimalToFeetInches & LTrim$(Str$(intFractions))
DecimalToFeetInches = DecimalToFeetInches & "/" & LTrim$(Str$(Denominator))
End If
DecimalToFeetInches = DecimalToFeetInches & Chr$(34)
End Function
Function FractUp(InputFt As Integer, InputInch As Integer, InputNum As Integer, InputDenom As Integer)
While InputNum Mod 2 = 0 And InputDenom Mod 2 = 0
InputNum = InputNum / 2
InputDenom = InputDenom / 2
Wend
If InputDenom = 1 Then ' Full inch
InputInch = InputInch + 1
InputNum = 0
If InputInch = 12 Then ' Full foot
InputFt = InputFt + 1
InputInch = 0
End If
End If
End Function
'---------------------------------------------------------------------------------
Sub SortDimensions()
Dim arr(1 To 3) As Double
arr(1) = Length
arr(2) = Width
arr(3) = Height
SortArr arr
End Sub
Sub SortArr(arr() As Double)
Dim i As Long
Dim j As Long
Dim tmp As String
Dim p As String
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
'---------------------------------------------------------------------------------
MsgBox (arr(1) & " x " & arr(2) & " x " & arr(3))
StockSize = (arr(1) & " x " & arr(2) & " x " & arr(3))
Set swCustProp = Part.Extension.CustomPropertyManager("")
retval = Part.DeleteCustomInfo2("", "外形尺寸") 'Remove existing properties
swCustProp.Add3 "外形尺寸", swCustomInfoText, StockSize, 1 'Add latest values
' ---------------------------------------------------------------------------------
End Sub
|
|
[复制链接]
楼主
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
转播
教程|习题|模型|技巧
点赞
拍砖
发表于 2021-8-5 09:31:57
发表于 2022-9-5 10:34:46
鲁公网安备 37028502190335号