尺寸驱动模型，写个通用的VBA代码，哪位大神能指导下？ - SolidWorks机械工程师网——最大的SolidWorks学习平台

'讀取SW零件的全部尺寸，寫到Excel。
'在Excel變動尺寸後，修改SW的零件尺寸。
函數SetSwPart（）
Dim SwApp作為對象
Dim SelMgr作為對象，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”）
' ***獲取Excel中的活動工作表
設置xl = GetObject（，“Excel.Application”）
設置xls = xl.ActiveSheet
使用
xls'nn = .range（“A65536”）。End（3）.Row'End（3） ==>
'設置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” “）
設置SwPart = SetSwPart
設置swFeat = SwPart.FirstFeature
kk = 1
做什麼不是swFeat什麼都不
Debug.Print”“+ swFeat.Name
設置swSubFeat = swFeat.GetFirstSubFeature
做什麼不swSubFeat什麼都不
Debug.Print”“+ swSubFeat。名稱
設置swDispDim = swSubFeat。GetFirstDisplayDimension
執行時不是swDispDim什麼都不是
設置swAnn = swDispDim.GetAnnotation
設置SwDim = swDispDim.GetDimension
Debug.Print“[”＆SwDim.FullName＆“] =”＆SwDim.GetSystemValue2（“”）
'Debug.Print swDim.FullName，swDim.GetSystemValue2（“”）
設置swDispDim = swSubFeat.GetNextDisplayDimension（swDispDim）
循環
集swSubFeat = swSubFeat.GetNextSubFeature
循環
集swDispDim = swFeat.GetFirstDisplayDimension
執行時沒有swDispDim沒有
設置swAnn = swDispDim.GetAnnotation
設置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（“”）
設置swDispDim = swFeat.GetNextDisplayDimension（swDispDim）
kk = kk + 1
循環
設置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）=分裂（oArr1（kk - 1），“@”）（1）
.cells（ kk，5 + cc）= oArr2（kk - 1）
下一個kk
nn = .range（“I65536”）。End（3）.Row'End（3）==> End（xlUp）Stop'Chen
停修改Excel之尺寸後，再按RUN執行鍵
Set Part = SwApp.ActiveDoc
'依據Excel變動值修改到sw零件
對於mm = 1到nn
Size_name = Mid（.cells（mm，9），2，Len（.cells（mm，9）） - 2）
Part.Parameter（Size_name）.SystemValue = .cells（mm，11）
下一個mm
結束用
boolStatus = Part.EditRebuild3（）
MsgBox“零件尺寸修改結束”
End Sub

复制代码