|
下载后把文件后缀.rar改为.swp即可,solidworks 2019,不知道低版本能否打开,我把代码也贴上来。
注:此非本人所能,乃高手随手所做。谢谢帮助!
Const toLayer1 As String = "尺寸标注"
Const toLayer2 As String = "中心线"
Const toLayer3 As String = "文字"
Const toLayer4 As String = "符号"
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim LyrMgr As LayerMgr
Dim Layer As Variant
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swAnn As SldWorks.Annotation
Dim swDispDim As SldWorks.DisplayDimension
Dim swCenterLine As SldWorks.Centerline
Dim swCtrMark As SldWorks.CenterMark
Dim swNote As SldWorks.Note
Dim swWeldSymbol As SldWorks.WeldSymbol
Dim swSFSymbol As SldWorks.SFSymbol
Dim swAnnDatumTag As SldWorks.DatumTag
Dim swAnnDatumTargetSym As SldWorks.DatumTargetSym
Dim numshts As Long
Dim i As Long
Dim SheetName() As String
Set swApp = CreateObject("sldworks.Application")
Set swModel = swApp.ActiveDoc
Set LyrMgr = swModel.GetLayerManager
Set swDraw = swModel
LyrMgr.DeleteLayer ("尺寸标注")
Layer = LyrMgr.AddLayer("尺寸标注", "尺寸标注", RGB(0, 128, 0), 0, 0) '指定顏色
LyrMgr.DeleteLayer ("中心线")
Layer = LyrMgr.AddLayer("中心线", "中心线", 255, 2, 0) '指定顏色
LyrMgr.DeleteLayer ("文字")
Layer = LyrMgr.AddLayer("文字", "文字", RGB(0, 0, 0), 0, 0) '指定顏色
LyrMgr.DeleteLayer ("符号")
Layer = LyrMgr.AddLayer("符号", "符号", RGB(0, 0, 0), 0, 0) '指定顏色
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.Color = -1
swAnn.Layer = toLayer1
Set swDispDim = swDispDim.GetNext3
Wend
Set swCtrMark = swView.GetFirstCenterMark
While Not swCtrMark Is Nothing
Set swAnn = swCtrMark.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer2
Set swCtrMark = swCtrMark.GetNext
Wend
Set swCenterLine = swView.GetFirstCenterLine
While Not swCenterLine Is Nothing
Set swAnn = swCenterLine.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer2
Set swCenterLine = swCenterLine.GetNext
Wend
Set swNote = swView.GetFirstNote
While Not swNote Is Nothing
Set swAnn = swNote.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer3
Set swNote = swNote.GetNext
Wend
Set swWeldSymbol = swView.GetFirstWeldSymbol
While Not swWeldSymbol Is Nothing
Set swAnn = swWeldSymbol.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer4
Set swWeldSymbol = swWeldSymbol.GetNext
Wend
Set swSFSymbol = swView.GetFirstSFSymbol
While Not swSFSymbol Is Nothing
Set swAnn = swSFSymbol.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer4
Set swSFSymbol = swSFSymbol.GetNext
Wend
Set swAnnDatumTag = swView.GetFirstDatumTag
While Not swAnnDatumTag Is Nothing
Set swAnn = swAnnDatumTag.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer4
Set swAnnDatumTag = swAnnDatumTag.GetNext
Wend
Set swAnnDatumTargetSym = swView.GetFirstDatumTargetSym
While Not swAnnDatumTargetSym Is Nothing
Set swAnn = swAnnDatumTargetSym.GetAnnotation
swAnn.Color = -1
swAnn.Layer = toLayer4
Set swAnnDatumTargetSym = swAnnDatumTargetSym.GetNext
Wend
Set swView = swView.GetNextView
Wend
swDraw.SheetNext
Dim swLayerMgr As Object
Dim swLayer As Object
Set swLayerMgr = swModel.GetLayerManager
swLayerMgr.SetCurrentLayer ("")
Next i
SheetName = swDraw.GetSheetNames
swDraw.ActivateSheet SheetName(0)
End Sub
|
|