Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
phantuhuong

Các ví dụ về sử dụng VBA trong AutoCad

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

Tôi mở mục này để các bạn có thể post các ví dụ về sử dụng VBA trong AutoCad:

 

1. Vẽ đường cong nối giữa 2 điểm được chọn: Sử dụng spline

 

Sub Tao_Spline()

' Duong noi phan chia cac lop
Dim NoilopSPL As AcadSpline
Dim Batdau As Variant: Dim Ketthuc As Variant
Dim KhcachX As Double: Dim KhcachY As Double: Dim CulyY As Double
Dim Diemnoi(0 To 14) As Double
Dim startTan(0 To 2) As Double: Dim endTan(0 To 2) As Double

With ThisDrawing.Utility
  Batdau = .GetPoint(, "Chon Diemnoi dau tien")
  Ketthuc = .GetPoint(, "Chon Diemnoi cuoi cung")
End With
  KhcachX = Abs(Ketthuc(0) - Batdau(0))
  KhcachY = Abs(Ketthuc(1) - Batdau(1))
  CulyY = KhcachY / 4


  startTan(0) = 0: startTan(1) = 0
  endTan(0) = 0: endTan(1) = 0

If Ketthuc(1) > Batdau(1) Then
  Diemnoi(0) = Batdau(0)
  Diemnoi(1) = Batdau(1)

  Diemnoi(3) = Batdau(0) + KhcachX / 4
  Diemnoi(4) = Batdau(1) + 2 * CulyY / 4

  Diemnoi(6) = Batdau(0) + KhcachX / 2
  Diemnoi(7) = Batdau(1) + 2 * CulyY

  Diemnoi(9) = Batdau(0) + 3 * KhcachX / 4
  Diemnoi(10) = Batdau(1) + 13 * CulyY / 4

  Diemnoi(12) = Ketthuc(0)
  Diemnoi(13) = Ketthuc(1)

Else

  Diemnoi(0) = Batdau(0)
  Diemnoi(1) = Batdau(1)

  Diemnoi(3) = Batdau(0) + KhcachX / 4
  Diemnoi(4) = Batdau(1) - 2 * CulyY / 4

  Diemnoi(6) = Batdau(0) + KhcachX / 2
  Diemnoi(7) = Batdau(1) - 2 * CulyY

  Diemnoi(9) = Batdau(0) + 3 * KhcachX / 4
  Diemnoi(10) = Batdau(1) - 10 * CulyY / 3

  Diemnoi(12) = Ketthuc(0)
  Diemnoi(13) = Ketthuc(1)

End If

Set NoilopSPL = ThisDrawing.ModelSpace.AddSpline(Diemnoi, startTan, endTan)
	NoilopSPL.Update
ZoomAll

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

2. Xác định đối tượng và toạ độ điểm: (sưu tầm)

 

Sub Cor()
On Error GoTo kt

'Chon doi tuong tren ban ve
Dim Entry As AcadObject
Dim Point As Variant

ThisDrawing.Utility.GetEntity Entry, Point, "Chon mot doi tuong (Line or Pline): "

'Neu la doi tuong Line
If Entry.ObjectName = "AcDbLine" Then
 Dim objLine As AcadLine

 Set objLine = Entry

 MsgBox "Doi tuong la Line" & ", chieu dai: " & objLine.Length & Chr(13) + Chr(10) & _
 "Toa do diem dau (X,Y,Z): " & objLine.StartPoint(0) & "; " & objLine.StartPoint(1) & "; " & objLine.StartPoint(2) & Chr(13) + Chr(10) & _
 "Toa do diem cuoi (X,Y,Z): " & objLine.EndPoint(0) & "; " & objLine.EndPoint(1) & "; " & objLine.EndPoint(2) & Chr(13) + Chr(10) & _
 "Toa do diem giua (X,Y,Z): " & (objLine.StartPoint(0) + objLine.EndPoint(0)) / 2 & "; " & (objLine.StartPoint(1) + objLine.EndPoint(1)) / 2 & "; " & (objLine.StartPoint(2) + objLine.EndPoint(2)) / 2

End If

'Neu la Polyline hoac 2D Polyline
Dim thongbao As String
Dim i As Long
Dim coord As Variant
Dim sodinh As Long
Dim NameObject As String
Dim Dai As Double

sodinh = 0
NameObject = ""
Dai = 0

'Neu la Polyline
If Entry.ObjectName = "AcDbPolyline" Then
 Dim objPolyline As AcadLWPolyline

 Set objPolyline = Entry
 NameObject = "Polyline"

 Dai = objPolyline.Length
 coord = objPolyline.Coordinates

 i = 0
tiep:
 thongbao = thongbao & "Toa do diem thu " & (i / 2 + 1) & " (X,Y): " & coord(i) & "; " & coord(i + 1) & Chr(13) + Chr(10)
 sodinh = (i / 2 + 1)
 i = i + 2
 GoTo tiep

End If

'Neu doi tuong la 2D Polyline
If Entry.ObjectName = "AcDb2dPolyline" Then
 Dim obj2DPolyline As AcadPolyline

 Set obj2DPolyline = Entry
 NameObject = "2D Polyline"
 Dai = obj2DPolyline.Length

 coord = obj2DPolyline.Coordinates

 i = 0
tiep1:
 thongbao = thongbao & "Toa do diem thu " & (i / 3 + 1) & " (X,Y,Z): " & coord(i) & "; " & coord(i + 1) & "; " & coord(i + 2) & Chr(13) + Chr(10)
 sodinh = (i / 3 + 1)
 i = i + 3
 GoTo tiep1

End If

Exit Sub
kt:
If sodinh > 0 Then MsgBox "Doi tuong la " & NameObject & ", co " & sodinh & " dinh, chieu dai: " & Dai & Chr(13) + Chr(10) & thongbao
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

Ví dụ dưới đây sử dụng VBA Excel để xác định chiều dài đường Polyline, chiều dài line và thông tin về các đối tượng trong bản vẽ AutoCad (nếu dùng Cad2004 thì không phải khai lại thư viện).

 

http://www.cadviet.com/upfiles/AutoCADEnti...elMacroMenu.zip

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

Mạo muội, viết thêm chủ đề của bác "phantuhuong".. anh em thử xài một tiện ích thay thế block này bằng 1 block khác.

Tiện ích có giao diện thân thiện dễ xài... hơn nữa open code

rpeblock.jpg

blockreplace.dvb

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
2. Xác định đối tượng và toạ độ điểm: (sưu tầm)

 

Sub Cor()
On Error GoTo kt

'Chon doi tuong tren ban ve
Dim Entry As AcadObject
Dim Point As Variant

ThisDrawing.Utility.GetEntity Entry, Point, "Chon mot doi tuong (Line or Pline): "

'Neu la doi tuong Line
If Entry.ObjectName = "AcDbLine" Then
 Dim objLine As AcadLine

 Set objLine = Entry

 MsgBox "Doi tuong la Line" & ", chieu dai: " & objLine.Length & Chr(13) + Chr(10) & _
 "Toa do diem dau (X,Y,Z): " & objLine.StartPoint(0) & "; " & objLine.StartPoint(1) & "; " & objLine.StartPoint(2) & Chr(13) + Chr(10) & _
 "Toa do diem cuoi (X,Y,Z): " & objLine.EndPoint(0) & "; " & objLine.EndPoint(1) & "; " & objLine.EndPoint(2) & Chr(13) + Chr(10) & _
 "Toa do diem giua (X,Y,Z): " & (objLine.StartPoint(0) + objLine.EndPoint(0)) / 2 & "; " & (objLine.StartPoint(1) + objLine.EndPoint(1)) / 2 & "; " & (objLine.StartPoint(2) + objLine.EndPoint(2)) / 2

End If

'Neu la Polyline hoac 2D Polyline
Dim thongbao As String
Dim i As Long
Dim coord As Variant
Dim sodinh As Long
Dim NameObject As String
Dim Dai As Double

sodinh = 0
NameObject = ""
Dai = 0

'Neu la Polyline
If Entry.ObjectName = "AcDbPolyline" Then
 Dim objPolyline As AcadLWPolyline

 Set objPolyline = Entry
 NameObject = "Polyline"

 Dai = objPolyline.Length
 coord = objPolyline.Coordinates

 i = 0
tiep:
 thongbao = thongbao & "Toa do diem thu " & (i / 2 + 1) & " (X,Y): " & coord(i) & "; " & coord(i + 1) & Chr(13) + Chr(10)
 sodinh = (i / 2 + 1)
 i = i + 2
 GoTo tiep

End If

'Neu doi tuong la 2D Polyline
If Entry.ObjectName = "AcDb2dPolyline" Then
 Dim obj2DPolyline As AcadPolyline

 Set obj2DPolyline = Entry
 NameObject = "2D Polyline"
 Dai = obj2DPolyline.Length

 coord = obj2DPolyline.Coordinates

 i = 0
tiep1:
 thongbao = thongbao & "Toa do diem thu " & (i / 3 + 1) & " (X,Y,Z): " & coord(i) & "; " & coord(i + 1) & "; " & coord(i + 2) & Chr(13) + Chr(10)
 sodinh = (i / 3 + 1)
 i = i + 3
 GoTo tiep1

End If

Exit Sub
kt:
If sodinh > 0 Then MsgBox "Doi tuong la " & NameObject & ", co " & sodinh & " dinh, chieu dai: " & Dai & Chr(13) + Chr(10) & thongbao
End Sub

 

Bây giờ em có thể lấy tọa độ của nhiều Line cùng một lúc được không ạ ?

Xin cám ơn bác !

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

minh có 1 đoạn mã vba dùng để xuất tọa độ sang excel ,nhưng mỗi lần mình kích hoạt nó lại luôn bắt đầu bằng stt là  1 ,nhờ các cao thủ trên diễn đàn chỉnh sửa giúp là mình có thể nhập vào stt cho mỗi lần bắt đầu dc ko 

http://www.cadviet.com/upfiles/3/52714_module_3.rar

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  

×