Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
7 replies to this topic

#1 sanit

sanit

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 30 July 2012 - 02:09 PM

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 !
  • 0

#2 khatamxd

khatamxd

    biết vẽ ellipse

  • Members
  • PipPip
  • 50 Bài viết
Điểm đánh giá: 21 (tàm tạm)

Đã gửi 30 July 2012 - 02:46 PM

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 đó.
  • 1

#3 sanit

sanit

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 30 July 2012 - 03:26 PM

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.
  • 1

#4 phantuhuong

phantuhuong

    biết dimstyle

  • Moderator
  • PipPipPipPipPip
  • 383 Bài viết
Điểm đánh giá: 200 (khá)

Đã gửi 06 August 2012 - 10:10 PM

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.
  • 1
Bồi dưỡng Excel & VBA cho các đơn vị ở Hà Nội và khu vực lân cận

Từng bước loại đồ Tàu ra khỏi cuộc sống!


#5 NguyenNgocSon

NguyenNgocSon

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 368 Bài viết
Điểm đánh giá: 39 (tàm tạm)

Đã gửi 06 August 2012 - 10:14 PM

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 :)
  • 0

#6 sanit

sanit

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 3 (bình thường)

Đã gửi 06 August 2012 - 10:49 PM

Đâ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.c...files/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

  • 0

#7 kegiaumat

kegiaumat

    biết vẽ circle

  • Members
  • PipPip
  • 39 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 26 November 2012 - 10:21 AM

anh ơi sao báo lỗi ở Dim objVBComponent As VBIDE.VBComponent
  • 0

#8 phantuhuong

phantuhuong

    biết dimstyle

  • Moderator
  • PipPipPipPipPip
  • 383 Bài viết
Điểm đánh giá: 200 (khá)

Đã gửi 26 November 2012 - 04:13 PM

Một Tool hỗ trợ cho AutoCad 2000 đây:

http://www.cadforum....ID.asp?tip=1933
  • 0
Bồi dưỡng Excel & VBA cho các đơn vị ở Hà Nội và khu vực lân cận

Từng bước loại đồ Tàu ra khỏi cuộc sống!