nguyenvanvien
Thành viên mới
![](/diendan/data/PhoToDanhHieu/gold.gif)
- Tham gia
- 28/9/06
- Bài viết
- 30
- Được thích
- 43
Tôi có viết 1 CT nhưng báo lỗi, các bạn giúp sửa lại dùm :
Từ môi trường excel, chương trình sẽ lấy giá trị tại ô A1, sau đó sẽ chuyển qua AutoCAD, chương trình yêu cầu chọn 1 Polyline, sau khi người dùng chọn Polyline thì chương trình sẽ vẽ các đường tròn bán kính bằng ô B1 theo phương của đường Polyline.
Ví dụ cụ thể : Có 1 Polyline có tọa độ như sau:
A(0,0); B(200,200); C(400,200), giá trị ô A1 là 5, giá trị ô B1 là 3 thì chương trình sẽ vẽ 5 đường tròn bán kính bằng 3 nằm đều trên Polyline. 1 đường tròn tại A(0,0), 1 đường tròn tại C(400,200), còn lại ở giữa có 3 đường tròn
Tuy nhiên chương trình bị báo lỗi tại dòng ptArray = pline.GetPointAtDist(dist) ' LaY TOA DO DIEM TU KHOANG CACH
Từ môi trường excel, chương trình sẽ lấy giá trị tại ô A1, sau đó sẽ chuyển qua AutoCAD, chương trình yêu cầu chọn 1 Polyline, sau khi người dùng chọn Polyline thì chương trình sẽ vẽ các đường tròn bán kính bằng ô B1 theo phương của đường Polyline.
Ví dụ cụ thể : Có 1 Polyline có tọa độ như sau:
A(0,0); B(200,200); C(400,200), giá trị ô A1 là 5, giá trị ô B1 là 3 thì chương trình sẽ vẽ 5 đường tròn bán kính bằng 3 nằm đều trên Polyline. 1 đường tròn tại A(0,0), 1 đường tròn tại C(400,200), còn lại ở giữa có 3 đường tròn
Tuy nhiên chương trình bị báo lỗi tại dòng ptArray = pline.GetPointAtDist(dist) ' LaY TOA DO DIEM TU KHOANG CACH
Mã:
Option Explicit
Sub DrawCirclesAlongPolyline()
Dim acadApp As Object
Dim acadDoc As Object
Dim pline As Object
Dim ptArray As Variant
Dim i As Integer
Dim Ban_kinh As Double
Dim SLDuong_tron As Integer
Dim CDDuong_thang As Double
Dim KCDt_Dt As Double
Dim dist As Double
Dim pt As Variant
Dim acadCircle As Object
' Lay du lieu tu Excel
SLDuong_tron = Range("A1").Value
Ban_kinh = Range("B1").Value
' Kiem tra
If SLDuong_tron < 2 Then
MsgBox "So luong duong tron pha >= 2", vbCritical, "L?i"
Exit Sub
End If
If Ban_kinh <= 0 Then
MsgBox "Ban kinh duong tron phai > 0", vbCritical, "L?i"
Exit Sub
End If
' Ket noi AutoCAD
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application") ' Kiem tra xem AutoCAD có chay khong
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application") ' Neu chua chay thi mo AutoCAD
End If
acadApp.Visible = True ' Hien thi AutoCAD
On Error GoTo 0
' Mo ban ve hien tai
Set acadDoc = acadApp.ActiveDocument
' Yeu cau nguoi dung chon 1 Polyline
MsgBox "Vui lòng ch?n m?t Polyline trong AutoCAD.", vbInformation, "Hu?ng d?n"
acadDoc.Utility.GetEntity pline, pt, "Chon mot Polyline: "
' Kiem tra co phai Polyline không
If pline.ObjectName <> "AcDbPolyline" Then
MsgBox "Doi tuong khong phai là Polyline!", vbCritical, "Loi"
Exit Sub
End If
' Lay tong chieu dai Polyline
CDDuong_thang = pline.Length
' Tính khoang cach giua cac duong tron
KCDt_Dt = CDDuong_thang / (SLDuong_tron - 1)
' Ve duong tron tren Polyline
For i = 0 To SLDuong_tron - 1
dist = i * KCDt_Dt ' Khoang cach tu diem dau
ptArray = pline.GetPointAtDist(dist) ' LaY TOA DO DIEM TU KHOANG CACH
ptArray = pline.get
' Ve duong tron tai toa do xac dinh
Set acadCircle = acadDoc.ModelSpace.AddCircle(ptArray, Ban_kinh)
acadCircle.Update
Next i
End Sub