- 积分
- 385
- 明经币
- 个
- 注册时间
- 2018-6-6
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
下面是我写的一段代码,当是VBA调试时可以直接运行通过,但是在打开的一个DWg文件 通过工具栏按钮运行时,会打开样板文件,并为当前文件,但代码只会运行到msgbox "dd"这句之前,后面的就运行不了.我这段代码的主要作用是加载块和加载图层设置到模板里.
Public Sub AddBlockAndLayer()
Dim BLin As String
Dim KeyWords As String
On Error Resume Next
KeyWords = "Y N"
ThisDrawing.Utility.InitializeUserInput 1, KeyWords '设置关键词
BLin = ThisDrawing.Utility.GetKeyword("是否加载到样板:[加载(Y)/ 当前(N)]<N>:")
If BLin = "Y" Then
Dim preferences As AcadPreferences
Dim currTemplateDWGPath As String
Dim newTemplateDWGPath As String
Set preferences = ThisDrawing.Application.preferences
' 打开目前的 TemplateDWGPath值
currTemplateDWGPath = preferences.Files.QNewTemplateFile
Dim Doc As AcadDocument
Dim drawing As AcadDocument
Dim HasFind As Boolean
Dim DrawingPath As String
HasFind = flase
For Each drawing In ThisDrawing.Application.Documents
DrawingPath = drawing.Path & "\" & drawing.Name
If StrComp(currTemplateDWGPath, DrawingPath, vbTextCompare) = 0 Then
HasFind = True
Doc = drawing
Exit For
End If
Next drawing
If HasFind = False Then
Set Doc = ThisDrawing.Application.Documents.Open(currTemplateDWGPath)
End If
ThisDrawing.Application.ActiveDocument = Doc
MsgBox "dd" "从这样开始
Call AddBlocks
Call AddLayers
Exit Sub
Doc.Save
Doc.Close
Else
If BLin = "N" Then
Call AddBlocks
Call AddLayers
End If
End If
End Sub
|
|