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

Tháng 10 6, 2008

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

Tháng 10 6, 2008

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

Tháng 10 12, 2008

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

Tháng 10 17, 2008

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

blockreplace.dvb

Tháng 2 20, 2009

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 !

Tháng 11 30, 2010

Các 2pic về VBA dường như bị lãng quên :leluoi:

Tháng 11 30, 2013

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

Tháng 11 30, 2013

Của bạn đây, không biết có đúng ý bạn ko nữa.

http://www.cadviet.com/upfiles/3/37575_kira.rar

Đăng nhập

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

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

phantuhuong 213

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 213

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 213

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

tranchan 97

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

discovery 0

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

ketxu 2.947

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

xuanb3 0

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

dinhvantrang 151

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

Tạo tài khoản

Đăng nhập

Diễn đàn

Download

Đào tạo CADViet

Browse