单个文件更换绘图标准时，这个宏是有效的
Sub 更改绘图标准() DimswApp As SldWorks.SldWorks Dimpart As SldWorks.ModelDoc2 DimswModel As SldWorks.ModelDoc2 DimFN, TN As String FN = InputBox("请输入文件地址") FN = Replace(FN, Chr(34), "") Debug.Print FN TN = InputBox("请输入绘图标准地址") TN = Replace(TN, Chr(34), "") Debug.Print TN SetswApp = Application.SldWorks 'Set part = swApp.OpenDoc(FN, 1) '开启零件图,1为零件图，2为装配图，3为工程图 'Set part = swApp.OpenDoc(FN, 2) '开启装配图,1为零件图，2为装配图，3为工程图 Set part = swApp.OpenDoc(FN, 3) '开启工程图,1为零件图，2为装配图，3为工程图 Set swModel = swApp.ActiveDoc boolstatus =swModel.Extension.LoadDraftingStandard(TN) swModel.ForceRebuild3 (True) swModel.Save '保存 swApp.CloseDoc (FN) '关闭零件 End Sub 返回的boolstatus是true
但是遍历文件夹和子文件夹对工程图更换绘图标准时就不中了，代码如下：
Dim arrFiles() Dim cntFiles% Dim brrFiles() Dim FN As String Public Sub ListAllFiles() Dim strPath$ Dim i% Dim j% Dim fso As New FileSystemObject, fd As Folder Dim stemp As String Dim sp As String Dim DN As String Dim TN As String DN = InputBox("请输入文件夹地址") '复制文件夹地址为文本 TN = InputBox("请输入绘图标准地址") '复制文件夹地址为文本 If TN = "" Then Exit Sub TN = Replace(TN, Chr(34), "") '去掉文件名的引号 ReDim arrFiles(1 To 1000) ReDim brrFiles(1 To 1000) cntFiles = 0 Set fd = fso.GetFolder(DN) SearchFiles fd ReDim Preserve arrFiles(1 To cntFiles) For i = 1 To cntFiles If arrFiles(i) <> "" Then j = j + 1 brrFiles(j) = arrFiles(i) FN = brrFiles(j) Debug.Print FN 更改绘图标准 FN Else End If Next i End Sub Sub SearchFiles(ByVal fd As Folder) Dim fl As File Dim sfd As Folder Dim c As String Dim d As String For Each fl In fd.Files cntFiles = cntFiles + 1 If cntFiles > UBound(arrFiles) Then ReDim Preserve arrFiles(1 TocntFiles + 1000) '此处可加入文件名称或类型的判断 'c = f1.Path d = Right(fl.Path, 7) 'If d = ".SLDPRT" Then arrFiles(cntFiles) = fl.Path '此处筛选出零件，与之后的1对应 If d = ".SLDDRW" ThenarrFiles(cntFiles) = fl.Path '此处筛选出工程图，与之后的3对应 ‘If d = ".SLDASM" ThenarrFiles(cntFiles) = fl.Path '此处筛选出装配体，与之后的2对应 Next fl If fd.SubFolders.Count = 0 Then Exit Sub For Each sfd In fd.SubFolders SearchFiles sfd Next End Sub Sub 更改绘图标准(ByVal FNAs String) DimswApp As SldWorks.SldWorks Dimpart As SldWorks.ModelDoc2 DimswModel As SldWorks.ModelDoc2 SetswApp = Application.SldWorks 'Set part = swApp.OpenDoc(FN, 1) '开启零件图,1为零件图，2为装配图，3为工程图 'Set part = swApp.OpenDoc(FN, 2) '开启装配图,1为零件图，2为装配图，3为工程图 Set part = swApp.OpenDoc(FN, 3) '开启工程图,1为零件图，2为装配图，3为工程图 Set swModel = swApp.ActiveDoc boolstatus =swModel.Extension.LoadDraftingStandard(TN) swModel.ForceRebuild3 (True) Debug.Print boolstatus swModel.Save '保存 swApp.CloseDoc (FN) '关闭零件 End Sub Dim arrFiles() Dim cntFiles% Dim brrFiles() Dim FN As String Public Sub ListAllFiles() Dim strPath$ Dim i% Dim j% Dim fso As New FileSystemObject, fd As Folder Dim stemp As String Dim sp As String Dim DN As String Dim TN As String DN = InputBox("请输入文件夹地址") '复制文件夹地址为文本 TN = InputBox("请输入绘图标准地址") '复制文件夹地址为文本 If TN = "" Then Exit Sub TN = Replace(TN, Chr(34), "") '去掉文件名的引号 ReDim arrFiles(1 To 1000) ReDim brrFiles(1 To 1000) cntFiles = 0 Set fd = fso.GetFolder(DN) SearchFiles fd ReDim Preserve arrFiles(1 To cntFiles) For i = 1 To cntFiles If arrFiles(i) <> "" Then j = j + 1 brrFiles(j) = arrFiles(i) FN = brrFiles(j) Debug.Print FN 更改绘图标准 FN Else End If Next i End Sub Sub SearchFiles(ByVal fd As Folder) Dim fl As File Dim sfd As Folder Dim c As String Dim d As String For Each fl In fd.Files cntFiles = cntFiles + 1 If cntFiles > UBound(arrFiles) Then ReDim Preserve arrFiles(1 TocntFiles + 1000) '此处可加入文件名称或类型的判断 'c = f1.Path d = Right(fl.Path, 7) 'If d = ".SLDPRT" Then arrFiles(cntFiles) = fl.Path '此处筛选出零件，与之后的1对应 If d = ".SLDDRW" ThenarrFiles(cntFiles) = fl.Path '此处筛选出工程图，与之后的3对应 ‘If d = ".SLDASM" ThenarrFiles(cntFiles) = fl.Path '此处筛选出装配体，与之后的2对应 Next fl If fd.SubFolders.Count = 0 Then Exit Sub For Each sfd In fd.SubFolders SearchFiles sfd Next End Sub Sub 更改绘图标准(ByVal FNAs String) DimswApp As SldWorks.SldWorks Dimpart As SldWorks.ModelDoc2 DimswModel As SldWorks.ModelDoc2 SetswApp = Application.SldWorks 'Set part = swApp.OpenDoc(FN, 1) '开启零件图,1为零件图，2为装配图，3为工程图 'Set part = swApp.OpenDoc(FN, 2) '开启装配图,1为零件图，2为装配图，3为工程图 Set part = swApp.OpenDoc(FN, 3) '开启工程图,1为零件图，2为装配图，3为工程图 Set swModel = swApp.ActiveDoc boolstatus =swModel.Extension.LoadDraftingStandard(TN) swModel.ForceRebuild3 (True) Debug.Print boolstatus swModel.Save '保存 swApp.CloseDoc (FN) '关闭零件 End Sub 返回的boolstatus是false
求指教
| 
[复制链接]
楼主
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
转播
教程|习题|模型|技巧
点赞
拍砖
发表于 2023-3-6 06:51:16
鲁公网安备 37028502190335号