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

efan2000

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

<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 />

今晚打老虎

厉害厉害~~~~~~

zhu1

这真是个绝好的贴字

如果能够实现录制宏的功能

我们就不用花很多时间了

只要对宏进行修改就可以了

希望大家都来顶一下！

weekendor

鼓掌中！！！

zhuxuhong

不错!

gyl

不明白ACAD中为什么不提供这样的功能.

wmz

不知具体怎样实现(我没有看懂)?

Jianyu

没看懂,希望楼主讲明具体怎么实现.前面几个鼓掌的看懂了?厉害!比楼主还厉害!

lzx838

这可是个好贴子哦

MJTD_7777

看了这个帖子,知道什么是差距了.