Question

solidworks怎么通过VBA给特征尺寸赋予值

Answer 1

参考下面的的代码：

Function SetSwPart()
  Dim SwApp As Object
  Dim SelMgr As Object, boolStatus As Boolean
  Dim longstatus As Long, longwarnings As Long
  
  Set SwApp = GetObject(, "sldworks.application")
  
  Set SetSwPart = SwApp.ActiveDoc
  
End Function
''****************************

Private Sub ReadSwDimensionInSldPrt()
  ''读SW的变量数据
  Dim oDic
  Set oDic = CreateObject("Scripting.Dictionary")
    
  
  nn = Range("A65536").End(3).Row
  Set Rng = Range("A1:Z" & nn)
  
    Dim swFeat As Object, swSubFeat As Object
    Dim swDispDim As Object, SwDim As Object
    Dim swAnn As Object
    Dim bRet As Boolean
    Dim Str
    
    Set SwApp = CreateObject("SldWorks.Application")
    Set SwPart = SetSwPart
    Set swFeat = SwPart.FirstFeature
    
    
    kk = 1
    Do While Not swFeat Is Nothing
        Debug.Print "  " + swFeat.Name
        Set swSubFeat = swFeat.GetFirstSubFeature
        Do While Not swSubFeat Is Nothing
            Debug.Print "      " + swSubFeat.Name
            
            Set swDispDim = swSubFeat.GetFirstDisplayDimension
            Do While Not swDispDim Is Nothing
                Set swAnn = swDispDim.GetAnnotation
                Set SwDim = swDispDim.GetDimension
                Debug.Print "          [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
                'Debug.Print swDim.FullName, swDim.GetSystemValue2("")
                Set swDispDim = swSubFeat.GetNextDisplayDimension(swDispDim)
            Loop
            Set swSubFeat = swSubFeat.GetNextSubFeature
        Loop
        
        Set swDispDim = swFeat.GetFirstDisplayDimension
        Do While Not swDispDim Is Nothing
            Set swAnn = swDispDim.GetAnnotation
            Set SwDim = swDispDim.GetDimension
            
            Debug.Print "    [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
            Debug.Print SwDim.FullName, SwDim.GetSystemValue2("")
            Str = SwDim.FullName
            oArr = Split(Str, "@")
            Str = oArr(0) & "@" & oArr(1)
            '
            Cells(kk, 5) = SwDim.GetSystemValue2("")
            Cells(kk, 4) = oArr(1)
            Debug.Print SwDim.GetSystemValue2("")
            oDic(Str) = SwDim.GetSystemValue2("")
            
            Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
            kk = kk + 1
        Loop
        Set swFeat = swFeat.GetNextFeature
    Loop
    Dim oArr1, oArr2, cc
    cc = 6
    oArr1 = oDic.keys: oArr2 = oDic.items
    For kk = 1 To UBound(oArr1) + 1
        Cells(kk, 1 + cc) = kk - 1
        Cells(kk, 2 + cc) = "=" & """Arr(""" & " & " & Cells(kk, 1 + cc).Address(0, 0) & " & " & """)="""
        Cells(kk, 3 + cc) = "'" & Chr(34) & oArr1(kk - 1) & Chr(34)
        Cells(kk, 4 + cc) = Split(oArr1(kk - 1), "@")(1)
        Cells(kk, 5 + cc) = oArr2(kk - 1)
    
    Next kk
End Sub