[VBA程序]：类似录制宏的VBA代码示例。

efan2000

2. 
   
3.   [FONT=courier new]
   
4. 第一步，引用：Microsoft Visual Basic for Applications Extensibility 5.3类型库，这是用于扩展VBA功能的组件。
   
5. 第二步，在ThisDraiwntg中添加事件的监控，主要有对象的增加、修改、删除操作。以下只检测对象的创建，也只对直张的创建进行监控，当直线创建时，自动往工程中添加一个过程。
   
6. Private Sub AcadDocument_ObjectAdded(ByVal Object As Object)
   
7.     Select Case Object.ObjectName
   
8.         Case "AcDbLine"
   
9.             Dim lineObj As AcadLine
   
10.             Set lineObj = Object
    
11.             Dim ComponentObj As VBComponent
    
12.             Set ComponentObj = GetVBComponent(vbext_ct_StdModule)
    
13.             If ComponentObj Is Nothing Then
    
14.                 Set ComponentObj = Application.VBE.ActiveVBProject.VBComponents.Add(vbext_ct_StdModule)
    
15.             End If
    
16.             With ComponentObj.CodeModule
    
17.                 Dim s As String
    
18.                 s = "" & vbCrLf
    
19.                 s = "Sub 宏_Line" & GetProcCount(ComponentObj.CodeModule) + 1 & "()" & vbCrLf
    
20.                 s = s & "" & vbCrLf
    
21.                 s = s & "    ' 宏_Line" & GetProcCount(ComponentObj.CodeModule) + 1 & vbCrLf
    
22.                 s = s & "    ' efan2000 记录的宏" & vbCrLf
    
23.                 s = s & "" & vbCrLf
    
24.                 s = s & "    Dim lineObj As AcadLine" & vbCrLf
    
25.                 s = s & "    Dim startPoint(0 To 2) As Double" & vbCrLf
    
26.                 s = s & "    Dim endPoint(0 To 2) As Double" & vbCrLf
    
27.                 s = s & "" & vbCrLf
    
28.                 s = s & "    ' 定义直线的起点和终点" & vbCrLf
    
29.                 s = s & "    startPoint(0) = " & lineObj.startPoint(0) & ": startPoint(1) =  " & lineObj.startPoint(1) & ": startPoint(2) = 0" & vbCrLf
    
30.                 s = s & "    endPoint(0) = " & lineObj.endPoint(0) & ": endPoint(1) = " & lineObj.endPoint(1) & ": endPoint(2) = 0" & vbCrLf
    
31.                 s = s & "" & vbCrLf
    
32.                 s = s & "    ' 在模型空间创建直线" & vbCrLf
    
33.                 s = s & "    Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)" & vbCrLf
    
34.                 s = s & "    Set lineObj = Nothing" & vbCrLf
    
35.                 s = s & "End Sub" & vbCrLf
    
36.                 .InsertLines .CountOfLines + 1, s
    
37.             End With
    
38.     End Select
    
39. End Sub
    
40. 
    
41. '返回当前工程的第一个模块
    
42. Public Function GetVBComponent(ByVal ComponentType As vbext_ComponentType) As VBComponent
    
43.     Dim i As Integer
    
44.     For i = 1 To Application.VBE.ActiveVBProject.VBComponents.Count
    
45.         If Application.VBE.ActiveVBProject.VBComponents(i).Type = ComponentType Then
    
46.             Set GetVBComponent = Application.VBE.ActiveVBProject.VBComponents(i)
    
47.             Exit For
    
48.         End If
    
49.     Next
    
50. End Function
    
51. 
    
52. '返回模块中的过程数目
    
53. Public Function GetProcCount(ByVal CMObj As CodeModule) As Integer
    
54.     Dim i As Integer
    
55.     Dim s  As String
    
56.     For i = 1 To CMObj.CountOfLines
    
57.         If InStr(1, s, CMObj.ProcOfLine(i, vbext_pk_Proc), vbTextCompare) = 0 Then
    
58.             s = s & CMObj.ProcOfLine(i, vbext_pk_Proc) & ";"
    
59.         End If
    
60.     Next
    
61.     If s = "" Then Exit Function
    
62.     s = Left(s, Len(s) - 1)
    
63.     Dim v As Variant
    
64.     v = Split(s, ";")
    
65.     If Not IsEmpty(v) Then
    
66.         GetProcCount = UBound(v) + 1
    
67.     End If
    
68. End Function
    
69. 
    
70. 第三步，这是在事件中自动创建的代码结果。
    
71. Sub 宏_Line1()
    
72. 
    
73.     ' 宏_Line1
    
74.     ' efan2000 记录的宏
    
75. 
    
76.     Dim lineObj As AcadLine
    
77.     Dim startPoint(0 To 2) As Double
    
78.     Dim endPoint(0 To 2) As Double
    
79. 
    
80.     ' 定义直线的起点和终点
    
81.     startPoint(0) = 83.7160125997048: startPoint(1) = 206.265137503404: startPoint(2) = 0
    
82.     endPoint(0) = 259.874137686561: endPoint(1) = 243.32201842691: endPoint(2) = 0
    
83. 
    
84.     ' 在模型空间创建直线
    
85.     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    
86.     Set lineObj = Nothing
    
87. End Sub
    
88. 
    
89. Sub 宏_Line2()
    
90. 
    
91.     ' 宏_Line2
    
92.     ' efan2000 记录的宏
    
93. 
    
94.     Dim lineObj As AcadLine
    
95.     Dim startPoint(0 To 2) As Double
    
96.     Dim endPoint(0 To 2) As Double
    
97. 
    
98.     ' 定义直线的起点和终点
    
99.     startPoint(0) = 259.874137686561: startPoint(1) = 243.32201842691: startPoint(2) = 0
    
100.     endPoint(0) = 158.433236658299: endPoint(1) = 136.511009275691: endPoint(2) = 0
     
101. 
     
102.     ' 在模型空间创建直线
     
103.     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
     
104.     Set lineObj = Nothing
     
105. End Sub
     
106. 
     
107. Sub 宏_Line3()
     
108. 
     
109.     ' 宏_Line3
     
110.     ' efan2000 记录的宏
     
111. 
     
112.     Dim lineObj As AcadLine
     
113.     Dim startPoint(0 To 2) As Double
     
114.     Dim endPoint(0 To 2) As Double
     
115. 
     
116.     ' 定义直线的起点和终点
     
117.     startPoint(0) = 158.433236658299: startPoint(1) = 136.511009275691: startPoint(2) = 0
     
118.     endPoint(0) = 328.59216866062: endPoint(1) = 155.039449391691: endPoint(2) = 0
     
119. 
     
120.     ' 在模型空间创建直线
     
121.     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
     
122.     Set lineObj = Nothing
     
123. End Sub
     
124. 
     
125. 这仅仅是一个简单的功能，如果能够加以扩充，完全可以实现如在Excel中的录制宏的效果。
     
126.   [/FONT]
     

<br />   [FONT=courier new]<br /> 第一步，引用：Microsoft Visual Basic for Applications Extensibility 5.3类型库，这是用于扩展VBA功能的组件。<br /> 第二步，在ThisDraiwntg中添加事件的监控，主要有对象的增加、修改、删除操作。以下只检测对象的创建，也只对直张的创建进行监控，当直线创建时，自动往工程中添加一个过程。<br /> Private Sub AcadDocument_ObjectAdded(ByVal Object As Object)<br />     Select Case Object.ObjectName<br />         Case "AcDbLine"<br />             Dim lineObj As AcadLine<br />             Set lineObj = Object<br />             Dim ComponentObj As VBComponent<br />             Set ComponentObj = GetVBComponent(vbext_ct_StdModule)<br />             If ComponentObj Is Nothing Then<br />                 Set ComponentObj = Application.VBE.ActiveVBProject.VBComponents.Add(vbext_ct_StdModule)<br />             End If<br />             With ComponentObj.CodeModule<br />                 Dim s As String<br />                 s = "" & vbCrLf<br />                 s = "Sub 宏_Line" & GetProcCount(ComponentObj.CodeModule) + 1 & "()" & vbCrLf<br />                 s = s & "" & vbCrLf<br />                 s = s & "    ' 宏_Line" & GetProcCount(ComponentObj.CodeModule) + 1 & vbCrLf<br />                 s = s & "    ' efan2000 记录的宏" & vbCrLf<br />                 s = s & "" & vbCrLf<br />                 s = s & "    Dim lineObj As AcadLine" & vbCrLf<br />                 s = s & "    Dim startPoint(0 To 2) As Double" & vbCrLf<br />                 s = s & "    Dim endPoint(0 To 2) As Double" & vbCrLf<br />                 s = s & "" & vbCrLf<br />                 s = s & "    ' 定义直线的起点和终点" & vbCrLf<br />                 s = s & "    startPoint(0) = " & lineObj.startPoint(0) & ": startPoint(1) =  " & lineObj.startPoint(1) & ": startPoint(2) = 0" & vbCrLf<br />                 s = s & "    endPoint(0) = " & lineObj.endPoint(0) & ": endPoint(1) = " & lineObj.endPoint(1) & ": endPoint(2) = 0" & vbCrLf<br />                 s = s & "" & vbCrLf<br />                 s = s & "    ' 在模型空间创建直线" & vbCrLf<br />                 s = s & "    Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)" & vbCrLf<br />                 s = s & "    Set lineObj = Nothing" & vbCrLf<br />                 s = s & "End Sub" & vbCrLf<br />                 .InsertLines .CountOfLines + 1, s<br />             End With<br />     End Select<br /> End Sub<br /> <br /> '返回当前工程的第一个模块<br /> Public Function GetVBComponent(ByVal ComponentType As vbext_ComponentType) As VBComponent<br />     Dim i As Integer<br />     For i = 1 To Application.VBE.ActiveVBProject.VBComponents.Count<br />         If Application.VBE.ActiveVBProject.VBComponents(i).Type = ComponentType Then<br />             Set GetVBComponent = Application.VBE.ActiveVBProject.VBComponents(i)<br />             Exit For<br />         End If<br />     Next<br /> End Function<br /> <br /> '返回模块中的过程数目<br /> Public Function GetProcCount(ByVal CMObj As CodeModule) As Integer<br />     Dim i As Integer<br />     Dim s  As String<br />     For i = 1 To CMObj.CountOfLines<br />         If InStr(1, s, CMObj.ProcOfLine(i, vbext_pk_Proc), vbTextCompare) = 0 Then<br />             s = s & CMObj.ProcOfLine(i, vbext_pk_Proc) & ";"<br />         End If<br />     Next<br />     If s = "" Then Exit Function<br />     s = Left(s, Len(s) - 1)<br />     Dim v As Variant<br />     v = Split(s, ";")<br />     If Not IsEmpty(v) Then<br />         GetProcCount = UBound(v) + 1<br />     End If<br /> End Function<br /> <br /> 第三步，这是在事件中自动创建的代码结果。<br /> Sub 宏_Line1()<br /> <br />     ' 宏_Line1<br />     ' efan2000 记录的宏<br /> <br />     Dim lineObj As AcadLine<br />     Dim startPoint(0 To 2) As Double<br />     Dim endPoint(0 To 2) As Double<br /> <br />     ' 定义直线的起点和终点<br />     startPoint(0) = 83.7160125997048: startPoint(1) = 206.265137503404: startPoint(2) = 0<br />     endPoint(0) = 259.874137686561: endPoint(1) = 243.32201842691: endPoint(2) = 0<br /> <br />     ' 在模型空间创建直线<br />     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)<br />     Set lineObj = Nothing<br /> End Sub<br /> <br /> Sub 宏_Line2()<br /> <br />     ' 宏_Line2<br />     ' efan2000 记录的宏<br /> <br />     Dim lineObj As AcadLine<br />     Dim startPoint(0 To 2) As Double<br />     Dim endPoint(0 To 2) As Double<br /> <br />     ' 定义直线的起点和终点<br />     startPoint(0) = 259.874137686561: startPoint(1) = 243.32201842691: startPoint(2) = 0<br />     endPoint(0) = 158.433236658299: endPoint(1) = 136.511009275691: endPoint(2) = 0<br /> <br />     ' 在模型空间创建直线<br />     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)<br />     Set lineObj = Nothing<br /> End Sub<br /> <br /> Sub 宏_Line3()<br /> <br />     ' 宏_Line3<br />     ' efan2000 记录的宏<br /> <br />     Dim lineObj As AcadLine<br />     Dim startPoint(0 To 2) As Double<br />     Dim endPoint(0 To 2) As Double<br /> <br />     ' 定义直线的起点和终点<br />     startPoint(0) = 158.433236658299: startPoint(1) = 136.511009275691: startPoint(2) = 0<br />     endPoint(0) = 328.59216866062: endPoint(1) = 155.039449391691: endPoint(2) = 0<br /> <br />     ' 在模型空间创建直线<br />     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)<br />     Set lineObj = Nothing<br /> End Sub<br /> <br /> 这仅仅是一个简单的功能，如果能够加以扩充，完全可以实现如在Excel中的录制宏的效果。<br />   [/FONT]<br />

subtlation

命令和操作很多，要一个个写，工作量很大的。而且有一些CAD的命令用vba写起来蛮费劲的。
autodesk公司应该开发开发。－－这样vba for autocad 的函数、属性、方法就多多了，用起来也方便多了。

秋枫

同意。这个我们用户来实现太费力了。如果碰上PEDIT，TRIM之类的命令，用VBA实现录制会疯掉的。