Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
Người theo dõi 0
sanit

[Hỏi] về công cụ Record VBA trong cad như trong office

Bởi sanit , trong Lập trình khác

Các bài được khuyến nghị

sanit    3

sanit
Đã đăng

Chào các bạn ! Mình đang tìm hiểu VBA for cad, và có thắc mắc muốn hỏi VBA for cad có hỗ trợ Record Macro như trong office không, hoặc các bạn có tool nào tương tự giới thị cho mình với.

Thanks !

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

khatamxd    21

khatamxd
Đã đăng

Chào các bạn ! Mình đang tìm hiểu VBA for cad, và có thắc mắc muốn hỏi VBA for cad có hỗ trợ Record Macro như trong office không, hoặc các bạn có tool nào tương tự giới thị cho mình với.

Thanks !

Cái này lúc trước mình cũng tìm mà ko thấy. Từ cad2009 có cái record nhưng nó ko cho ra được CODE như excel mà chỉ recode thao tác vẽ của bạn. Khi cho chạy thì nó làm lại những thao tác này.

Vấn đề VBA for cad cũng ko có j mới và trên Cadviet toàn pro nên bí quá thì bạn cứ hỏi chắc sẽ có giải đáp hữu ích cho bạn đó.

  • Vote tăng 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

sanit    3

sanit
Đã đăng

Hiện tại mình đang mày mò và học mót, nếu có Record thì dễ quan sát code phát sinh khi thực hiện lệnh.

Mình được biết là có công cụ Record này, nhưng hiện tại xin chưa được. ví dụ như vẽ đoạn thẳng bằng lệnh line nó sẽ lưu lại code VBA, sau đó run nó sẽ vẽ lại đoạn line này theo đúng định dạng Color, Layer, Linetype như khi vẽ, và công cụ đang còn hạn chế một số lệnh như lệnh Rectang.

  • Vote tăng 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

phantuhuong    217

phantuhuong
Đã đăng

Hiện tại mình đang mày mò và học mót, nếu có Record thì dễ quan sát code phát sinh khi thực hiện lệnh.

Mình được biết là có công cụ Record này, nhưng hiện tại xin chưa được. ví dụ như vẽ đoạn thẳng bằng lệnh line nó sẽ lưu lại code VBA, sau đó run nó sẽ vẽ lại đoạn line này theo đúng định dạng Color, Layer, Linetype như khi vẽ, và công cụ đang còn hạn chế một số lệnh như lệnh Rectang.

 

Microsoft đã ngừng hỗ trợ VBA for AutoCad và Office rồi. Do đó những tồn tại đều phải tự khắc phục thôi.

  • Vote tăng 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

NguyenNgocSon    43

NguyenNgocSon
Đã đăng

VBA được cái gần với VB. Nếu lập trình thì mới học có lẽ dễ gần hơn, kiểm tra lỗi đơn giản theo thứ tự

Microsoft ngừng VBA ta tận dụng chuyển sang VB6 cũng là 1 cách hay :)

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

sanit    3

sanit
Đã đăng

Đây là code VBA ghi lại một số lệnh khi thực hiện trong Autocad, nhờ các bác phát triển tiếp bổ sung cho anh em tự học dễ hơn !

Link : http://www.cadviet.com/upfiles/3/111417_

 

Option Explicit
Private bRecorderStarted As Boolean
Private objVBE As Object
Private objVBComponent As Object
Const QUOTE = """"
Public Sub Record()
 InitVBE
 NewModule
 bRecorderStarted = True
End Sub
Private Sub InitVBE()
 Set objVBE = Application.VBE
End Sub
Private Sub NewModule()
 If Not CheckForModule Then

With objVBE.ActiveVBProject
 	With .VBComponents.Add(vbext_ct_StdModule)
   	.Name = "NewMacros"
 	End With
End With
 End If
End Sub
Private Function CheckForModule() As Boolean
Dim objVBComponent As VBIDE.VBComponent

CheckForModule = False
 For Each objVBComponent In objVBE.ActiveVBProject.VBComponents
If objVBComponent.Name = "NewMacros" Then
 	CheckForModule = True
 	Exit Function
End If
 Next objVBComponent
End Function
Private Sub AddMacro_Arc(Object As AcadObject)
Dim oArc As AcadArc
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
bRecorderStarted = False
Exit Sub
 End If

 Set oArc = Object
 If ThisDrawing.ActiveSpace Then

strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadArc As AcadArc"
.InsertLines (.CountOfLines + 1), "Dim Center(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim Radius As Double"
.InsertLines (.CountOfLines + 1), "Dim StartAngle As Double"
.InsertLines (.CountOfLines + 1), "Dim EndAngle As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Center(0) = " & oArc.Center(0)
.InsertLines (.CountOfLines + 1), "  Center(1) = " & oArc.Center(1)
.InsertLines (.CountOfLines + 1), "  Center(2) = " & oArc.Center(2)
.InsertLines (.CountOfLines + 1), "  Radius = " & oArc.Radius
.InsertLines (.CountOfLines + 1), "  StartAngle = " & oArc.StartAngle
.InsertLines (.CountOfLines + 1), "  EndAngle = " & oArc.EndAngle
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadArc = ThisDrawing." & strSpace & ".AddArc(Center, Radius, StartAngle, EndAngle)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadArc"
.InsertLines (.CountOfLines + 1), "	.Color = " & oArc.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oArc.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oArc.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oArc.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oArc.Lineweight
.InsertLines (.CountOfLines + 1), "	.Thickness = " & oArc.Thickness
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 bRecorderStarted = False
End Sub
Private Sub AddMacro_Circle(Object As AcadObject)
Dim oCircle As AcadCircle
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
bRecorderStarted = False
Exit Sub
 End If

 Set oCircle = Object

 If ThisDrawing.ActiveSpace Then
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadCircle As AcadCircle"
.InsertLines (.CountOfLines + 1), "Dim Center(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim Radius As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Center(0) = " & oCircle.Center(0)
.InsertLines (.CountOfLines + 1), "  Center(1) = " & oCircle.Center(1)
.InsertLines (.CountOfLines + 1), "  Center(2) = " & oCircle.Center(2)
.InsertLines (.CountOfLines + 1), "  Radius = " & oCircle.Radius
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadCircle = ThisDrawing." & strSpace & ".AddCircle(Center, Radius)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadCircle"
.InsertLines (.CountOfLines + 1), "	.Color = " & oCircle.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oCircle.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oCircle.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oCircle.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oCircle.Lineweight
.InsertLines (.CountOfLines + 1), "	.Thickness = " & oCircle.Thickness
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With
 bRecorderStarted = False
End Sub
Private Sub AddMacro_Ellipse(Object As AcadObject)
Dim oEllipse As AcadEllipse
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
bRecorderStarted = False
Exit Sub
 End If

 Set oEllipse = Object

 If ThisDrawing.ActiveSpace Then
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadEllipse As AcadEllipse"
.InsertLines (.CountOfLines + 1), "Dim Center(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim MajorAxis(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim RadiusRatio As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Center(0) = " & oEllipse.Center(0)
.InsertLines (.CountOfLines + 1), "  Center(1) = " & oEllipse.Center(1)
.InsertLines (.CountOfLines + 1), "  Center(2) = " & oEllipse.Center(2)
.InsertLines (.CountOfLines + 1), "  MajorAxis(0) = " & oEllipse.MajorAxis(0)
.InsertLines (.CountOfLines + 1), "  MajorAxis(1) = " & oEllipse.MajorAxis(1)
.InsertLines (.CountOfLines + 1), "  MajorAxis(2) = " & oEllipse.MajorAxis(2)
.InsertLines (.CountOfLines + 1), "  RadiusRatio = " & oEllipse.RadiusRatio
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadEllipse = ThisDrawing." & strSpace & ".AddEllipse(Center, MajorAxis, RadiusRatio)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadEllipse"
.InsertLines (.CountOfLines + 1), "	.Color = " & oEllipse.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oEllipse.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oEllipse.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oEllipse.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oEllipse.Lineweight
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 bRecorderStarted = False
End Sub
Private Sub AddMacro_Line(Object As AcadObject)
Dim oLine As AcadLine
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
bRecorderStarted = False
Exit Sub
 End If

 Set oLine = Object

 If ThisDrawing.ActiveSpace Then
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadLine As AcadLine"
.InsertLines (.CountOfLines + 1), "Dim StartPoint(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim EndPoint(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  StartPoint(0) = " & oLine.StartPoint(0)
.InsertLines (.CountOfLines + 1), "  StartPoint(1) = " & oLine.StartPoint(1)
.InsertLines (.CountOfLines + 1), "  StartPoint(2) = " & oLine.StartPoint(2)
.InsertLines (.CountOfLines + 1), "  EndPoint(0) = " & oLine.EndPoint(0)
.InsertLines (.CountOfLines + 1), "  EndPoint(1) = " & oLine.EndPoint(1)
.InsertLines (.CountOfLines + 1), "  EndPoint(2) = " & oLine.EndPoint(2)
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadLine = ThisDrawing." & strSpace & ".AddLine(StartPoint, EndPoint)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadLine"
.InsertLines (.CountOfLines + 1), "	.Color = " & oLine.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oLine.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oLine.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oLine.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oLine.Lineweight
.InsertLines (.CountOfLines + 1), "	.Thickness = " & oLine.Thickness
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 bRecorderStarted = False
End Sub
Private Sub AddMacro_Point(Object As AcadObject)
Dim oPoint As AcadPoint
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
bRecorderStarted = False
Exit Sub
 End If

 Set oPoint = Object

 If ThisDrawing.ActiveSpace Then
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadPoint As AcadPoint"
.InsertLines (.CountOfLines + 1), "Dim Point(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Point(0) = " & oPoint.Coordinates(0)
.InsertLines (.CountOfLines + 1), "  Point(1) = " & oPoint.Coordinates(1)
.InsertLines (.CountOfLines + 1), "  Point(2) = " & oPoint.Coordinates(2)
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadPoint = ThisDrawing." & strSpace & ".AddPoint(Point)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadPoint"
.InsertLines (.CountOfLines + 1), "	.Color = " & oPoint.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oPoint.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oPoint.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oPoint.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oPoint.Lineweight
.InsertLines (.CountOfLines + 1), "	.Thickness = " & oPoint.Thickness
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 bRecorderStarted = False
End Sub
Private Sub AddMacro_Polyline(Object As AcadObject)
Dim oLWPolyline As AcadLWPolyline
Dim strAnswer As String
Dim strSpace As String
Dim lngVertices As Long
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
bRecorderStarted = False
Exit Sub
 End If
 Set oLWPolyline = Object
 If ThisDrawing.ActiveSpace Then
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadLWPolyline As AcadLWPolyline"
.InsertLines (.CountOfLines + 1), "Dim VerticesList(" & UBound(oLWPolyline.Coordinates) & ")" & " As Double"
.InsertLines (.CountOfLines + 1), " "

For lngVertices = 0 To UBound(oLWPolyline.Coordinates)
 	.InsertLines (.CountOfLines + 1), "  VerticesList(" & lngVertices & ") = " & oLWPolyline.Coordinates(lngVertices)
Next lngVertices

.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadLWPolyline = ThisDrawing." & strSpace & ".AddLightweightPolyline(VerticesList)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadLWPolyline"
.InsertLines (.CountOfLines + 1), "	.Closed = " & oLWPolyline.Closed
.InsertLines (.CountOfLines + 1), "	.Color = " & oLWPolyline.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oLWPolyline.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oLWPolyline.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oLWPolyline.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oLWPolyline.Lineweight
.InsertLines (.CountOfLines + 1), "	.Thickness = " & oLWPolyline.Thickness
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 'turn off recorder
 bRecorderStarted = False
End Sub
Private Sub AddMacro_Ray(Object As AcadObject)
Dim oRay As AcadRay
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
'user cancelled, turn off recording
bRecorderStarted = False
Exit Sub
 End If

 'cast object to proper data type
 Set oRay = Object

 'figure out the proper space
 If ThisDrawing.ActiveSpace Then
'model space is active
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadRay As AcadRay"
.InsertLines (.CountOfLines + 1), "Dim Point1(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim Point2(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim DirectionVector(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Point1(0) = " & oRay.BasePoint(0)
.InsertLines (.CountOfLines + 1), "  Point1(1) = " & oRay.BasePoint(1)
.InsertLines (.CountOfLines + 1), "  Point1(2) = " & oRay.BasePoint(2)
.InsertLines (.CountOfLines + 1), "  Point2(0) = " & oRay.SecondPoint(0)
.InsertLines (.CountOfLines + 1), "  Point2(1) = " & oRay.SecondPoint(1)
.InsertLines (.CountOfLines + 1), "  Point2(2) = " & oRay.SecondPoint(2)
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadRay = ThisDrawing." & strSpace & ".AddRay(Point1, Point2)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadRay"
.InsertLines (.CountOfLines + 1), "	.Color = " & oRay.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oRay.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oRay.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oRay.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oRay.Lineweight
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 'turn off recorder
 bRecorderStarted = False
End Sub
Private Sub AddMacro_Spline(Object As AcadObject)
Dim oSpline As AcadSpline
Dim strAnswer As String
Dim strSpace As String
Dim lngFitPoints As Long
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
'user cancelled, turn off recording
bRecorderStarted = False
Exit Sub
 End If

 'cast object to proper data type
 Set oSpline = Object

 'figure out the proper space
 If ThisDrawing.ActiveSpace Then
'model space is active
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadSpline As AcadSpline"
.InsertLines (.CountOfLines + 1), "Dim StartTangent(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim EndTangent(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim FitPoints(" & UBound(oSpline.FitPoints) & ")" & " As Double"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  StartTangent(0) = " & oSpline.StartTangent(0)
.InsertLines (.CountOfLines + 1), "  StartTangent(1) = " & oSpline.StartTangent(1)
.InsertLines (.CountOfLines + 1), "  StartTangent(2) = " & oSpline.StartTangent(2)
.InsertLines (.CountOfLines + 1), "  EndTangent(0) = " & oSpline.EndTangent(0)
.InsertLines (.CountOfLines + 1), "  EndTangent(1) = " & oSpline.EndTangent(1)
.InsertLines (.CountOfLines + 1), "  EndTangent(2) = " & oSpline.EndTangent(2)

For lngFitPoints = 0 To UBound(oSpline.FitPoints)
 	.InsertLines (.CountOfLines + 1), "  FitPoints(" & lngFitPoints & ") = " & oSpline.FitPoints(lngFitPoints)
Next lngFitPoints

.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadSpline = ThisDrawing." & strSpace & ".AddSpline(FitPoints, StartTangent, EndTangent)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadSpline"
.InsertLines (.CountOfLines + 1), "	.Color = " & oSpline.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oSpline.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oSpline.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oSpline.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oSpline.Lineweight
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 'turn off recorder
 bRecorderStarted = False
End Sub
Private Sub AddMacro_MText(Object As AcadObject)
Dim oMText As AcadMText
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
'user cancelled, turn off recording
bRecorderStarted = False
Exit Sub
 End If

 'cast object to proper data type
 Set oMText = Object

 'figure out the proper space
 If ThisDrawing.ActiveSpace Then
'model space is active
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadMText As AcadMText"
.InsertLines (.CountOfLines + 1), "Dim InsertionPoint(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim Width As Double"
.InsertLines (.CountOfLines + 1), "Dim Text As String"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  InsertionPoint(0) = " & oMText.InsertionPoint(0)
.InsertLines (.CountOfLines + 1), "  InsertionPoint(1) = " & oMText.InsertionPoint(1)
.InsertLines (.CountOfLines + 1), "  InsertionPoint(2) = " & oMText.InsertionPoint(2)
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Width = " & oMText.Width
.InsertLines (.CountOfLines + 1), "  Text = " & QUOTE & oMText.TextString & QUOTE
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadMText = ThisDrawing." & strSpace & ".AddMText(InsertionPoint, Width, Text)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadMText"
.InsertLines (.CountOfLines + 1), "	.Color = " & oMText.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oMText.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oMText.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oMText.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oMText.Lineweight
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 'turn off recorder
 bRecorderStarted = False
End Sub
Private Sub AddMacro_Text(Object As AcadObject)
Dim oText As AcadText
Dim strAnswer As String
Dim strSpace As String
 strAnswer = InputBox("Enter macro name", "Macro Name Entry")

 If strAnswer = "" Then
'user cancelled, turn off recording
bRecorderStarted = False
Exit Sub
 End If

 'cast object to proper data type
 Set oText = Object

 'figure out the proper space
 If ThisDrawing.ActiveSpace Then
'model space is active
strSpace = "ModelSpace"

Else
 	strSpace = "PaperSpace"
 End If
 With objVBE.ActiveVBProject.VBComponents("NewMacros").CodeModule
.InsertLines (.CountOfLines + 1), "Public Sub " & strAnswer & "()"
.InsertLines (.CountOfLines + 1), "Dim oAcadText As AcadText"
.InsertLines (.CountOfLines + 1), "Dim InsertionPoint(0 to 2) As Double"
.InsertLines (.CountOfLines + 1), "Dim Height As Double"
.InsertLines (.CountOfLines + 1), "Dim TextString As String"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  InsertionPoint(0) = " & oText.InsertionPoint(0)
.InsertLines (.CountOfLines + 1), "  InsertionPoint(1) = " & oText.InsertionPoint(1)
.InsertLines (.CountOfLines + 1), "  InsertionPoint(2) = " & oText.InsertionPoint(2)
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Height = " & oText.Height
.InsertLines (.CountOfLines + 1), "  TextString = " & QUOTE & oText.TextString & QUOTE
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  Set oAcadText = ThisDrawing." & strSpace & ".AddText(TextString, InsertionPoint, Height)"
.InsertLines (.CountOfLines + 1), " "
.InsertLines (.CountOfLines + 1), "  With oAcadText"
.InsertLines (.CountOfLines + 1), "	.Color = " & oText.Color
.InsertLines (.CountOfLines + 1), "	.Layer = " & QUOTE & oText.Layer & QUOTE
.InsertLines (.CountOfLines + 1), "	.Linetype = " & QUOTE & oText.Linetype & QUOTE
.InsertLines (.CountOfLines + 1), "	.LinetypeScale = " & oText.LinetypeScale
.InsertLines (.CountOfLines + 1), "	.Lineweight = " & oText.Lineweight
.InsertLines (.CountOfLines + 1), "	.Thickness = " & oText.Thickness
.InsertLines (.CountOfLines + 1), "  End With"
.InsertLines (.CountOfLines + 1), "End Sub"
.InsertLines (.CountOfLines + 1), " "
 End With

 'turn off recorder
 bRecorderStarted = False
End Sub
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
Dim oAcadObject As AcadObject
 If bRecorderStarted Then
If CommandName = "PLINE" Then
 	With ThisDrawing.ModelSpace
   	Set oAcadObject = ThisDrawing.ObjectIdToObject(.Item(.Count - 1).ObjectID)
   	AddMacro_Polyline oAcadObject
 	End With
End If
 End If
End Sub
Private Sub AcadDocument_ObjectAdded(ByVal Object As Object)
 'if Caption is "Stop" then we're in record mode
 If bRecorderStarted Then
Select Case UCase(Object.ObjectName)
 	'Arc object added
 	Case "ACDBARC"
   	AddMacro_Arc Object

 	'Circle object added
 	Case "ACDBCIRCLE"
   	AddMacro_Circle Object

 	'Ellipse object added
 	Case "ACDBELLIPSE"
   	AddMacro_Ellipse Object

 	'Line object added
 	Case "ACDBLINE"
   	AddMacro_Line Object

 	'Point object added
 	Case "ACDBPOINT"
   	AddMacro_Point Object

 	'Ray object added
 	Case "ACDBRAY"
   	AddMacro_Ray Object

 	'Spline object added
 	Case "ACDBSPLINE"
   	AddMacro_Spline Object

 	'MText object added
 	Case "ACDBMTEXT"
   	AddMacro_MText Object

 	'Text object added
 	Case "ACDBTEXT"
   	AddMacro_Text Object
End Select
 End If
 'uncomment to determine exact object name used by AutoCAD
 'Debug.Print Object.ObjectName
End Sub

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay
Đăng nhập để thực hiện theo  
Người theo dõi 0
Về Đầu Trang Lập trình khác
×