Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
7 replies to this topic

#1 phantuhuong

phantuhuong

    biết dimstyle

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

Đã gửi 06 October 2008 - 01:40 PM

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

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


#2 phantuhuong

phantuhuong

    biết dimstyle

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

Đã gửi 06 October 2008 - 01:59 PM

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

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


#3 phantuhuong

phantuhuong

    biết dimstyle

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

Đã gửi 12 October 2008 - 11:15 PM

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.c...elMacroMenu.zip
  • 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!


#4 tranchan

tranchan

    biết lệnh break

  • Members
  • PipPipPipPip
  • 221 Bài viết
Điểm đánh giá: 93 (tàm tạm)

Đã gửi 17 October 2008 - 01:26 PM

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
Hình đã gửi
blockreplace.dvb
  • 0

#5 discovery

discovery

    biết pan

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

Đã gửi 20 February 2009 - 02:02 PM

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

#6 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 30 November 2010 - 11:23 PM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#7 xuanb3

xuanb3

    Chưa sử dụng CAD

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

Đã gửi 30 November 2013 - 01:00 PM

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.c...14_module_3.rar


  • 0

#8 dinhvantrang

dinhvantrang

    biết lệnh copy

  • Members
  • PipPipPip
  • 117 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 30 November 2013 - 01:45 PM

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

 http://www.cadviet.c.../37575_kira.rar


  • 1

Thanks and Best Regards

Skype : dinhvantrang73