建立外形属性的宏

api163

之前发贴求助过https://www.icax.org/forum.php?m ... ;extra=#pid11527543
现进行到了一个阶段，大家看一下





代码如下:
'Outline外形属性设置
'2014.12.24于福州
Sub main()

    Dim swApp   As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    Dim A, B, C, T As Double
    Dim DM As String

    '取各属性值
    A = swModel.GetCustomInfoValue("", "A")
    B = swModel.GetCustomInfoValue("", "B")
    C = swModel.GetCustomInfoValue("", "C")
    DM = swModel.GetCustomInfoValue("", "DM") '圆柱或螺纹等的前缀

    swModel.DeleteCustomInfo2 "", "Outline" '删除原Outline属性

    If (A <> -1) Then '如果A尺寸不是-1，说明它是一个方形的零件

    '对三个尺寸排序
        T = IIf(A > B, A, B)
        B = IIf(A > B, B, A)
        A = T

        T = IIf(A > C, A, C)
        C = IIf(A > C, C, A)
        A = T

        T = IIf(B > C, B, C)
        C = IIf(B > C, C, B)
        B = T
        swModel.AddCustomInfo3 "", "Outline", swCustomInfoText, Trim(Str(A)) & "X" & Trim(Str(B)) & "X" & Trim(Str(C)) '建立Outline属性

    Else '如果A尺寸不是-1，说明它是一个圆柱形的或一个螺纹形的零件

        swModel.AddCustomInfo3 "", "Outline", swCustomInfoText, DM & Trim(Str(B)) & "X" & Trim(Str(C)) 'Str()会去掉尾0
    End If
End Sub

gt.adan

api163

api163

api163