请问有没有一键改图纸格式的宏

wwwerzhou

   经典图书

请问有没有一键改图纸格式的宏,如图片所示，一键改图纸格式宏，一键改绘图标准宏，两个宏命令

心无止境

模板路径自己设置下，2018测试没有问题，感谢@yni621  的更换图层代码

Alex_Wang

   经典图书

顶一下！！！！！！！！！！！！！！！

sunwise

顶一下，坐等高手！

wetiuer

   经典案例图书

论坛中更换图纸模板的宏有很多，可以搜索一下。大概代码如下（VB.NET）

1. Private Sub ReplaceDrawingTemplate(ByRef swDraw As DrawingDoc, ByVal DrawingTemplateDic As Dictionary(Of Integer, String))
   
2.         Dim swSheet As Sheet
   
3.         Dim sheetProperties As Double()
   
4.         Dim vSheetName As Object()
   
5. 
   
6.         vSheetName = swDraw.GetSheetNames
   
7.         For Each sheetName As String In vSheetName
   
8.             swDraw.ActivateSheet(sheetName)
   
9.             swSheet = swDraw.Sheet(sheetName)
   
10.             sheetProperties = swSheet.GetProperties2
    
11.             For Each temp As KeyValuePair(Of Integer, String) In DrawingTemplateDic
    
12.                 If temp.Key = sheetProperties(0) Then
    
13.                     swSheet.SetProperties2(sheetProperties(0), swDwgTemplates_e.swDwgTemplateCustom, sheetProperties(2), sheetProperties(3), sheetProperties(4), sheetProperties(5), sheetProperties(6), sheetProperties(7))
    
14.                     swSheet.SetTemplateName(temp.Value)
    
15.                     swSheet.ReloadTemplate(False)
    
16.                 End If
    
17.             Next
    
18.         Next
    
19.     End Sub

复制代码

另外有一个批量工具实现，如下图

wwwerzhou

wetiuer 发表于 2022-6-7 15:45
论坛中更换图纸模板的宏有很多，可以搜索一下。大概代码如下（VB.NET）
另外有一个批量工具实现，如下图
...

感谢，批量复制有好多插件也可以，就是有时候需要单个的，一键宏命令

心无止境

   经典案例图书

可以实现的

wwwerzhou

心无止境 发表于 2022-6-9 20:59
可以实现的

插件在哪下载，谢谢

心无止境

wwwerzhou 发表于 2022-6-10 16:23
插件在哪下载，谢谢

插件暂时不对外开放，可以给你写个宏

wwwerzhou

   经典图书

心无止境 发表于 2022-6-10 22:43
插件暂时不对外开放，可以给你写个宏

感谢老师，麻烦写个宏

心无止境

wwwerzhou 发表于 2022-6-11 08:27
感谢老师，麻烦写个宏

标准层自己也要改下或者设置成和宏里面的一样

DFFDSGG114485

感谢楼主分享，很不错！

淡淡的雲

很不错，找到组织了！

wwwerzhou

心无止境 发表于 2022-6-11 17:44
模板路径自己设置下，2018测试没有问题，感谢@yni621  的更换图层代码

大师你好，是不是这几个打钩的都需要更改啊？
你看看我改的对不对，还有能不能含中文字？

心无止境

加入QQ群
参与讨论和学习

或扫描二维码加入

wwwerzhou 发表于 2022-6-13 10:49
大师你好，是不是这几个打钩的都需要更改啊？
你看看我改的对不对，还有能不能含中文字？

是的呀，全路径就行了

wwwerzhou

   经典案例图书

心无止境 发表于 2022-6-13 13:00
是的呀，全路径就行了

我可以看一下你的设置吗，就像我截图的那个，我设置好之后，只有图层改过来了，其他的都没变过来，不知道是不是我哪里没设置对

wwwerzhou

加入QQ群
参与讨论和学习

或扫描二维码加入

心无止境 发表于 2022-6-13 13:00
是的呀，全路径就行了

Const tolayer As String = "FORMAT"                     '设置到标注层
Sub main()
Dim swapp As SldWorks.SldWorks
Dim swmodel As SldWorks.ModelDoc2
Dim swdraw As SldWorks.DrawingDoc
Dim swview As SldWorks.View
Dim swann As SldWorks.Annotation
Dim swdispdim As SldWorks.DisplayDimension
Dim numshts As Long
Dim i As Long
Dim swErrors As Long
Dim swWarnings As Long
Dim boolstatus As Boolean
Dim Sheet As Object
Dim SheetPr() As Double
Dim SheetName As String
Dim StdFile As String
Set swapp = CreateObject("sldworks.application")
Set swmodel = swapp.ActiveDoc
Set swdraw = swmodel
Set Sheet = swdraw.GetCurrentSheet()
SheetPr = Sheet.GetProperties2()
SheetPr(0) = 12
SheetPr(1) = 12
If swmodel Is Nothing Then
swapp.SendMsgToUser ("当前没有任何文档打开，该程序必须在工程图中运行！")
Exit Sub
ElseIf swmodel.GetType <> 3 Then
swapp.SendMsgToUser ("当前打开的文档不是一个工程图，请打开工程图后再试！")
Exit Sub
End If
boolstatus = Sheet.SetProperties2(SheetPr(0), SheetPr(1), SheetPr(2), SheetPr(3), SheetPr(4), SheetPr(5), SheetPr(6), SheetPr(7))
StdFile = "E:\Program Files\MOBAN\GCTMB.drwdot" '双引号内填写工程图模板完整的地址及后缀.drwdot
If SheetPr(5) = 1189 / 1000 And SheetPr(6) = 841 / 1000 Then 'A0图幅
    Sheet.SetTemplateName ("")
    swdraw.Extension.LoadDraftingStandard StdFile
ElseIf SheetPr(5) = 841 / 1000 And SheetPr(6) = 594 / 1000 Then 'A1图幅
    Sheet.SetTemplateName ("")
    swdraw.Extension.LoadDraftingStandard StdFile
ElseIf SheetPr(5) = 594 / 1000 And SheetPr(6) = 420 / 1000 Then 'A2图幅
    Sheet.SetTemplateName ("")
    swdraw.Extension.LoadDraftingStandard StdFile
ElseIf SheetPr(5) = 420 / 1000 And SheetPr(6) = 297 / 1000 Then 'A3图幅
    Sheet.SetTemplateName ("")
    swdraw.Extension.LoadDraftingStandard StdFile
ElseIf SheetPr(5) = 297 / 1000 And SheetPr(6) = 210 / 1000 Then 'A4图幅
    Sheet.SetTemplateName ("E:\Program Files\MOBAN\THTK.slddrt") '双引号内填写图纸格式完整的地址及后缀.slddrt
    swdraw.Extension.LoadDraftingStandard StdFile
ElseIf SheetPr(5) = 210 / 1000 And SheetPr(6) = 297 / 1000 Then 'A4p图幅
    Sheet.SetTemplateName ("")
    swdraw.Extension.LoadDraftingStandard StdFile
End If
'更换绘图标准
boolstatus = swdraw.Extension.LoadDraftingStandard("E:\Program Files\MOBAN\GBXG.sldstd") '双引号内填写绘图标准完整的地址及后缀.sldstd
Sheet.ReloadTemplate (False) '重装图纸格式，删除原有注释
'更换图层
numshts = swdraw.GetSheetCount
For i = 1 To numshts
  swdraw.SheetPrevious
Next i
For i = 1 To numshts
  Set swview = swdraw.GetFirstView
  While Not swview Is Nothing
  Set swdispdim = swview.GetFirstDisplayDimension
  While Not swdispdim Is Nothing
  Set swann = swdispdim.GetAnnotation
  swann.Layer = tolayer
  Set swdispdim = swdispdim.GetNext3
  Wend
  Set swview = swview.GetNextView
  Wend
  swdraw.SheetNext
  Next i
boolstatus = swdraw.Save3(1, swErrors, swWarnings) '保存
swapp.SendMsgToUser ("已完成")
End Sub

Alex_Wang

   经典案例图书

心无止境 发表于 2022-6-11 17:44
模板路径自己设置下，2018测试没有问题，感谢@yni621  的更换图层代码

感谢大神无私分享！！！！！！！！！！！！！！！！

duanli96

心无止境 发表于 2022-6-9 20:59
可以实现的

大佬，插件能分享吗

心无止境

duanli96 发表于 2022-9-14 09:57
大佬，插件能分享吗

不好意思，这个暂时不对外。