[VBA]：类似录制宏的VBA代码示例。
第一步，引用：Microsoft Visual Basic for Applications Extensibility 5.3类型库，这是用于扩展VBA功能的组件。
第二步，在ThisDraiwntg中添加事件的监控，主要有对象的增加、修改、删除操作。以下只检测对象的创建，也只对直张的创建进行监控，当直线创建时，自动往工程中添加一个过程。
Private Sub AcadDocument_ObjectAdded(ByVal Object As Object)
Select Case Object.ObjectName
Case "AcDbLine"
Dim lineObj As AcadLine
Set lineObj = Object
Dim ComponentObj As VBComponent
Set ComponentObj = GetVBComponent(vbext_ct_StdModule)
If ComponentObj Is Nothing Then
Set ComponentObj = Application.VBE.ActiveVBProject.VBComponents.Add(vbext_ct_StdModule)
End If
With ComponentObj.CodeModule
Dim s As String
s = "" & vbCrLf
s = "Sub 宏_Line" & GetProcCount(ComponentObj.CodeModule) + 1 & "()" & vbCrLf
s = s & "" & vbCrLf
s = s & " ' 宏_Line" & GetProcCount(ComponentObj.CodeModule) + 1 & vbCrLf
s = s & " ' efan2000 记录的宏" & vbCrLf
s = s & "" & vbCrLf
s = s & " Dim lineObj As AcadLine" & vbCrLf
s = s & " Dim startPoint(0 To 2) As Double" & vbCrLf
s = s & " Dim endPoint(0 To 2) As Double" & vbCrLf
s = s & "" & vbCrLf
s = s & " ' 定义直线的起点和终点" & vbCrLf
s = s & " startPoint(0) = " & lineObj.startPoint(0) & ": startPoint(1) =" & lineObj.startPoint(1) & ": startPoint(2) = 0" & vbCrLf
s = s & " endPoint(0) = " & lineObj.endPoint(0) & ": endPoint(1) = " & lineObj.endPoint(1) & ": endPoint(2) = 0" & vbCrLf
s = s & "" & vbCrLf
s = s & " ' 在模型空间创建直线" & vbCrLf
s = s & " Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)" & vbCrLf
s = s & " Set lineObj = Nothing" & vbCrLf
s = s & "End Sub" & vbCrLf
.InsertLines .CountOfLines + 1, s
End With
End Select
End Sub
'返回当前工程的第一个模块
Public Function GetVBComponent(ByVal ComponentType As vbext_ComponentType) As VBComponent
Dim i As Integer
For i = 1 To Application.VBE.ActiveVBProject.VBComponents.Count
If Application.VBE.ActiveVBProject.VBComponents(i).Type = ComponentType Then
Set GetVBComponent = Application.VBE.ActiveVBProject.VBComponents(i)
Exit For
End If
Next
End Function
'返回模块中的过程数目
Public Function GetProcCount(ByVal CMObj As CodeModule) As Integer
Dim i As Integer
Dim sAs String
For i = 1 To CMObj.CountOfLines
If InStr(1, s, CMObj.ProcOfLine(i, vbext_pk_Proc), vbTextCompare) = 0 Then
s = s & CMObj.ProcOfLine(i, vbext_pk_Proc) & ";"
End If
Next
If s = "" Then Exit Function
s = Left(s, Len(s) - 1)
Dim v As Variant
v = Split(s, ";")
If Not IsEmpty(v) Then
GetProcCount = UBound(v) + 1
End If
End Function
第三步，这是在事件中自动创建的代码结果。
Sub 宏_Line1()
' 宏_Line1
' efan2000 记录的宏
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
' 定义直线的起点和终点
startPoint(0) = 83.7160125997048: startPoint(1) = 206.265137503404: startPoint(2) = 0
endPoint(0) = 259.874137686561: endPoint(1) = 243.32201842691: endPoint(2) = 0
' 在模型空间创建直线
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
Set lineObj = Nothing
End Sub
Sub 宏_Line2()
' 宏_Line2
' efan2000 记录的宏
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
' 定义直线的起点和终点
startPoint(0) = 259.874137686561: startPoint(1) = 243.32201842691: startPoint(2) = 0
endPoint(0) = 158.433236658299: endPoint(1) = 136.511009275691: endPoint(2) = 0
' 在模型空间创建直线
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
Set lineObj = Nothing
End Sub
Sub 宏_Line3()
' 宏_Line3
' efan2000 记录的宏
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
' 定义直线的起点和终点
startPoint(0) = 158.433236658299: startPoint(1) = 136.511009275691: startPoint(2) = 0
endPoint(0) = 328.59216866062: endPoint(1) = 155.039449391691: endPoint(2) = 0
' 在模型空间创建直线
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
Set lineObj = Nothing
End Sub
这仅仅是一个简单的功能，如果能够加以扩充，完全可以实现如在Excel中的录制宏的效果。
厉害厉害~~~~~~ 这真是个绝好的贴字
如果能够实现录制宏的功能
我们就不用花很多时间了
只要对宏进行修改就可以了
希望大家都来顶一下！
鼓掌中！！！
不错! 不明白ACAD中为什么不提供这样的功能.
不知具体怎样实现(我没有看懂)? 没看懂,希望楼主讲明具体怎么实现.前面几个鼓掌的看懂了?厉害!比楼主还厉害!
这可是个好贴子哦 看了这个帖子,知道什么是差距了.
页:
[1]