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

Code vẽ mặt cắt với những kích thước khác nhau qua VBA lấy số liệu từ excel

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

Đây là một chương trình ví dụ qua code VBA các bạn có thể vẽ được nhiều mặt cắt hình dạng giống nhau nhưng kích thước giống nhau thông qua số liệu các bạn nhập từ Excel. Bản Excel này các bạn có thể tự lập. Một điểm cần lưu ý ở đây chính là đường dẫn liên kết bản excel các bạn nhập số liệu trên VBA và tên của bản Excel đó (dòng này mình đã in đậm). Chương trình này mình viết với hình dạng mặt cắt mình có. Các bạn với những mặt cắt khác có thể làm tương tự. Hình dạng mặt cắt của mình các bạn có thể xem trong Form bài viết của mình theo link này http://www.giaiphapexcel.com/forum/s...d-qua-code-VBA để nhập số liệu cho thích hợp.Mình mong bài này có thể giúp ích gì đó cho các bạn. Trong phần code bài này phần đầu không khác chương trình mình đã gửi kia chỉ thêm một chương trình con liên kết với excel, bên cạnh đó mình có sửa một chút ở đường kích thước kt8 chương trình trước có một chút lỗi nhỏ ở đó.

 

Option Explicit

'khai bao du lieu mo ta

Public Type D_Cau

b1 As Double

b2 As Double

b3 As Double

b4 As Double

b5 As Double

b6 As Double

h1 As Double

h2 As Double

h3 As Double

h4 As Double

h5 As Double

h6 As Double

End Type

'khai bao du lieu toan cuc

Public Const kcDim = 10

Public Const pi = 3.14159265358979

'chuong trinh const ve D_Cau

Private Sub veDcau(Cau As D_Cau, Gocve As Variant)

Dim L(1 To 15) As AcadLine

Dim SP As Variant, EP As Variant

've cac duong thang

ThisDrawing.ActiveLayer = ThisDrawing.Layers("netdam")

'line1

SP = Gocve: SP(0) = SP(0) - Cau.b1 / 2

EP = SP: EP(0) = EP(0) + Cau.b1

Set L(1) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line 2

EP = SP: EP(1) = EP(1) - Cau.h1

Set L(2) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line3

SP = EP: EP(0) = EP(0) + Cau.b2

Set L(3) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line4

SP = EP: EP(1) = EP(1) - Cau.h2

Set L(4) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line5

SP = EP: EP(0) = EP(0) + Cau.b3: EP(1) = EP(1) - Cau.h3

Set L(5) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line6

SP = EP: SP(0) = Gocve(0) - (Cau.b1 / 2 - Cau.b2 - Cau.b3)

EP(0) = SP(0) + Cau.b1 - 2 * Cau.b2 - 2 * Cau.b3

Set L(6) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line7

SP = EP: SP(0) = SP(0) - 2 * (Cau.b1 / 2 - Cau.b2 - Cau.b3) + Cau.b6

EP = SP: EP(1) = EP(1) - Cau.h4

Set L(7) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line8

SP = EP: EP(0) = EP(0) + Cau.b4

Set L(8) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line9

EP = SP: EP(0) = EP(0) - Cau.b5: EP(1) = EP(1) - Cau.h5

Set L(9) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line10

SP = EP: EP(0) = EP(0) + 2 * Cau.b5 + Cau.b4

Set L(10) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line11

EP = SP: EP(1) = EP(1) - Cau.h6

Set L(11) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line12

SP = EP: EP(0) = EP(0) + Cau.b4 + 2 * Cau.b5

Set L(12) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line13

SP = EP: EP(1) = EP(1) + Cau.h6

Set L(13) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line14

SP = EP: EP(0) = EP(0) - Cau.b5: EP(1) = EP(1) + Cau.h5

Set L(14) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'line15

SP = EP: EP(1) = EP(1) + Cau.h4

Set L(15) = ThisDrawing.ModelSpace.AddLine(SP, EP)

'lay doi xung tu L-2,3,4,5,7,8,9,10,11,12,13,14,15 qua truc y

SP = Gocve: EP = Gocve: EP(1) = EP(1) + 100

L(2).Mirror SP, EP: L(3).Mirror SP, EP: L(4).Mirror SP, EP: L(5).Mirror SP, EP: L(7).Mirror SP, EP

L(8).Mirror SP, EP: L(9).Mirror SP, EP: L(10).Mirror SP, EP: L(11).Mirror SP, EP: L(12).Mirror SP, EP

L(13).Mirror SP, EP: L(14).Mirror SP, EP: L(15).Mirror SP, EP

'ghi kich thuoc

ThisDrawing.ActiveLayer = ThisDrawing.Layers("Kichthuoc")

Dim Vitri As Variant 'diem dat kich thuoc

'kt1

SP = L(1).StartPoint: EP = SP: EP(0) = EP(0) + Cau.b1

Vitri = SP: Vitri(1) = SP(1) + kcDim

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, 0

'kt2

SP = L(1).StartPoint: EP = L(2).EndPoint

Vitri = EP: Vitri(0) = Vitri(0) - kcDim

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, -pi / 2

'kt3

SP = L(2).EndPoint: EP = L(4).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, -pi / 2

'kt4

SP = L(4).EndPoint: EP = L(5).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, -pi / 2

'kt5

SP = L(5).EndPoint: EP = L(7).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, -pi / 2

'kt6

SP = L(9).StartPoint: EP = L(9).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, -pi / 2

'kt7

SP = L(11).StartPoint: EP = L(11).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, -pi / 2

'kt8

SP = L(3).StartPoint: EP = L(3).EndPoint

Vitri = SP: Vitri(1) = SP(1) + Cau.h1 / 2

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, 0

'kt9

SP = L(3).EndPoint: EP = L(5).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, 0

'kt10

SP = L(6).EndPoint

ThisDrawing.ModelSpace.AddDimRotated SP, EP, Vitri, 0

End Sub

 

Public Sub Project4()

Dim Cau As Chuongtrinh.D_Cau

Dim goc As Variant

Dim diembatdau As Variant

Dim appex As Excel.Application

Set appex = New Excel.Application

appex.Visible = False

Dim WB As Excel.Workbook

Dim WS As Excel.Worksheet

Set WB = appex.Workbooks.Open("E:whiterose232.xlsx")

Set WS = WB.Worksheets(1)

diembatdau = ThisDrawing.Utility.GetPoint(, "please choose the start point")

Dim i As Integer

i = 2

 

Do Until WS.Cells(i, 1).Value = ""

goc = diembatdau

goc(0) = goc(0) + 500 * (i - 2)

Cau.b1 = WS.Cells(i, 1).Value

Cau.b2 = WS.Cells(i, 2).Value

Cau.b3 = WS.Cells(i, 3).Value

Cau.b4 = WS.Cells(i, 4).Value

Cau.b5 = WS.Cells(i, 5).Value

Cau.b6 = WS.Cells(i, 6).Value

Cau.h1 = WS.Cells(i, 7).Value

Cau.h2 = WS.Cells(i, 8).Value

Cau.h3 = WS.Cells(i, 9).Value

Cau.h4 = WS.Cells(i, 10).Value

Cau.h5 = WS.Cells(i, 11).Value

Cau.h6 = WS.Cells(i, 12).Value

 

Chuongtrinh.veDcau Cau, goc

i = i + 1

Loop

End Sub

  • Vote tăng 1

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

Trong quá ttrình copy paste bài này của mình, mình lỡ làm mất một ký tự trong bài viết. nguyên bản là E:\whiterose232.xlsx chứ không phải E:whiterose232.xlsx. ^_^

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

Code để tạo ra đường dẫn động chứ không phải mặc định như là: E:\whiterose232.xlsx

Public Sub OpenFile()
'sample to show how to use FileDialogs
Dim objFile As FileDialogs
Dim strFilter As String
Dim strFileName As String
Set objFile = New FileDialogs
'desc,filter combinations must all be separated with pipe char "|"
  ' strFilter = "All Files (*.*)|*.*|Drawings (*.dwg)|*.dwg"
strFilter = "Excel 2007 (*.xlsx)|*.xlsx|Excel 2003 (*.xls)|*.xls"
objFile.OwnerHwnd = ThisDrawing.HWnd	'bind the dialog to the window
objFile.Title = "Open a File Excel-NguyenNgocSon"
'default dir is CurDir
objFile.StartInDir = "c:\"
objFile.Filter = strFilter
'return a valid filename
strFileName = objFile.ShowOpen
If Not strFileName = vbNullString Then
   	'use this space to perform operation
  MsgBoxUni UNC("B¹n chän file d÷ liÖu: ") & strFileName, vbOKOnly, UNC("Design by NguyÔn Ngäc S¬n")
End If
Tenfile = strFileName
Set objFile = Nothing
End Sub
  • Vote tăng 2

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

Anh cho em hỏi: Khi em viết code chương trình vẽ mặt cắt chữ T xong, lúc chạy thử chương trình thì máy báo là:

Runtime error

Automation error

The object invoked has disconected from it clients

Chương trình ko thể chạy được.

Vậy lỗi trên là lỗi gì và khắc phục nó như thế nào?

Mong anh giúp đỡ, Em rất cám ơn.

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ấn đề này bạn nên đưa code lên, hoặc chương trình cụ thể? Sẽ có nhiều người giúp bạn !

Mình chưa gặp lỗi đó bao giờ. Nhưng nhìn qua cái lỗi của bạn có lẽ do không tìm thấy thư viện tham chiếu, hoặc code lỗi

Thân !

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

Nhờ các anh giúp đỡ. Đây là code em viết. Cứ chạy là máy báo lỗi.

Code bên Userform

Private Sub CmdVematcat_Click()

Dim matcat As Chuongtrinh.Coc

matcat.a1 = Txta1.Value

matcat.b1 = Txtb1.Value

matcat.a2 = Txta2.Value

matcat.b2 = Txtb2.Value

matcat.R = TxtR.Value

 

Chuongtrinh.kt = Txtkt.Value

 

Cuasochinh.Hide

Dim Diemchon As Variant

ThisDrawing.Utility.Prompt "Chon Diem Bat Dau Ve: "

Diemchon = ThisDrawing.Utility.GetPoint()

 

Chuongtrinh.Vehinh matcat, Diemchon

 

End Sub

 

Code bên Module:

 

Option Explicit

 

Public Type Coc

a1 As Double

b1 As Double

a2 As Double

b2 As Double

R As Double

End Type

 

Public Const pi = 3.14159265358979

Public kt As Double

 

Public Sub Vehinh(matcat As Coc, Diemve As Variant)

Diemchon = Diemve

 

Dim L(1 To 2) As AcadLine

Dim sp As Variant, ep As Variant

 

ThisDrawing.ActiveLayer = ThisDrawing.ActiveLayers("Netdam")

 

sp = Diemve

ep = sp: ep(0) = ep(0) + matcat.a1

Set L(1) = ThisDrawing.ModelSpace.AddLine(sp, ep)

 

ep = sp

ep(1) = ep(1) - matcat.b1

Set L(2) = ThisDrawing.ModelSpace.AddLine(sp, ep)

 

Dim center As Variant

Dim Ac As AcadArc

Dim i As Long, j As Long

 

Diemve(0) = Diemve(0) + (matcat.a1 - 2 * matcat.a2) / 2

Diemve(1) = Diemve(1) - (matcat.b1 - matcat.b2) / 2

 

For i = 1 To 3

For j = 1 To 2

center(0) = Diemve(0) + (i - 1) * matcat.a2

center(1) = Diemve(1) - (j - 1) * matcat.b2

 

Set Ac = ThisDrawing.ModelSpace.AddArc(center, matcat.R)

Next

Next

 

sp = Diemve: sp(0) = sp(0) + matcat.a1 / 2

ep = sp: ep(1) = ep(1) + 100

L(2).Mirror sp, ep

 

sp = Diemve: sp(1) = sp(1) - matcat.b1 / 2

ep = sp: ep(0) = ep(0) + 100

L(1).Mirror sp, ep

 

ThisDrawing.ActiveLayer = ThisDrawing.ActiveLayers("Kichthuoc")

Dim vitri As Variant

 

sp = Diemve: ep = L(1).EndPoint

vitri = sp: vitri(1) = vitri(1) + kt

ThisDrawing.ModelSpace.AddDimRotated sp, ep, vitri, 0

 

sp = L(1).EndPoint

ep = sp: ep(1) = ep(1) - matcat.b1

vitri = ep: vitri(0) = vitri(0) + kt

ThisDrawing.ModelSpace.AddDimRotated sp, ep, vitri, pi / 2

 

sp = Ac.center: sp(0) = sp(0) - Ac.Radius

ThisDrawing.ModelSpace.AddDimRotated Ac.Radius, sp, Ac.center

 

 

End Sub

Rất mong các anh giúp em. Em cám ơn rất nhiều.Đây là file chương trình: http://www.cadviet.com/upfiles/3/65931_thanhhehe.rar

  • Vote tăng 1

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ình xem qua code có lẽ nên chia làm 3 hàm thì đơn giản hơn?

1.Hàm vẽ mặt bằng móng (HCN)

2.Hàm vẽ mặt bằng cọc (hình tròn)

3.Hàm ghi kích thước

Cách gọi hàm sai: Call Chuongtrinh.Vehinh(matcat, diemchon)

Mới check qua, bạn xem thử

Thân !

  • Vote tăng 1

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ình code lại cho bạn theo hướng tạo các Module con như sau:

Code bên Module:

Option Explicit
Public Type Coc
  	a1 As Double
  	b1 As Double
  	a2 As Double
  	b2 As Double
  	R As Double
End Type
Public Const pi = 3.14159265358979
Public kt As Double
Public Sub HCN(diemve As Variant, a As Double, b As Double)
Dim Rectang(0 To 7) As Double
Dim Pline As AcadLWPolyline
Dim BasePoint As Variant
'BasePoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "Diem chen:")
BasePoint = diemve
Rectang(0) = BasePoint(0)
Rectang(1) = BasePoint(1)
Rectang(2) = BasePoint(0)
Rectang(3) = BasePoint(1) + b
Rectang(4) = BasePoint(0) + a
Rectang(5) = BasePoint(1) + b
Rectang(6) = BasePoint(0) + a
Rectang(7) = BasePoint(1)
Set Pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(Rectang)
Pline.Closed = True
End Sub
Public Sub Hinhtron(tam As Variant, BK As Double)
Dim DT As AcadCircle
Set DT = ThisDrawing.ModelSpace.AddCircle(tam, BK)
End Sub

Code bên Userform

Private Sub CmdVematcat_Click()
Dim mep1, mep2 As Double
Dim i, j As Integer
Dim toado(2) As Double
Dim center(2) As Double
Dim matcat As Coc
With matcat
.a1 = Val(Txta1)
.b1 = Val(Txtb1)
.a2 = Val(Txta2)
.b2 = Val(Txtb2)
.R = Val(TxtR)
'Chuongtrinh.kt = Txtkt.Value
Cuasochinh.Hide
Dim diemchon As Variant
ThisDrawing.Utility.Prompt "Chon Diem Bat Dau Ve: "
diemchon = ThisDrawing.Utility.GetPoint()
Call HCN(diemchon, .a1, .b1)
mep1 = (.a1 - 2 * .a2) / 2
mep2 = (.b1 - .b2) / 2
toado(0) = diemchon(0) + mep1: toado(1) = diemchon(1) + mep2: toado(2) = diemchon(2)
'Call Hinhtron(toado, .R)
For i = 1 To 3
For j = 1 To 2
center(0) = toado(0) + (i - 1) * .a2
center(1) = toado(1) + (j - 1) * .b2
Call Hinhtron(center, .R)
Next j
Next i
End With
End Sub

Theo mình bạn nên tổng quát khi móng cọc gồm m hãng n cột như vậy sẽ đầy đủ hơn cho trường hợp i,j.

Phần ghi kích thước bạn nên tự làm

Thân!

Chúc bạn học tốt.http://www.cadviet.com/upfiles/3/48467_code.rar

  • Vote tăng 1

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

Chắc bạn là dân cầu đường.:D.

Theo mình không nên nhập thông số bề rộng móng mà nên nhập khoảng cách tim cọc, khoảng cách đến mép bệ => tự tính toán ra chiều rộng bệ móng sẽ hợp lý và hay hơn!

Thân!

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

e mới học lập trình không biết lệnh này viết sai ở chỗ nào.

mấy a xem hộ e với, sửa hộ e thì càng tốt

thân!!

 

 

private Sub CommandButton3_Click()

Dim lineobj As AcadLine

Dim startpoint(0 To 2) As Double

Dim endpoint(0 To 2) As Double

Dim objent As AcadArc

Dim center(0 To 2) As Double

Dim startangle As Double

Dim endangle As Double

startpoint(0) = 2: startpoint(1) = 1: startpoint(2) = 0

endpoint(0) = 4: endpoint(1) = 1: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

startpoint(0) = 5: startpoint(1) = 2: startpoint(2) = 0

endpoint(0) = 5: endpoint(1) = 3: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

startpoint(0) = 4: startpoint(1) = 4: startpoint(2) = 0

endpoint(0) = 2: endpoint(1) = 4: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

startpoint(0) = 1: startpoint(1) = 3: startpoint(2) = 0

endpoint(0) = 1: endpoint(1) = 2: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

center(0) = 2: center(1) = 2: center(2) = 0

startangle = 180 * 3.141592654 / 180

endangle = 270 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

center(0) = 2: center(1) = 3: center(2) = 0

startangle = 90 * 3.141592654 / 180

endangle = 180 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

center(0) = 4: center(1) = 3: center(2) = 0

startangle = 0 * 3.141592654 / 180

endangle = 90 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

center(0) = 4: center(1) = 2: center(2) = 0

startangle = 270 * 3.141592654 / 180

endangle = 360 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

 

 

' Xác d?nh tr?c d?i x?ng

Dim point1(0 To 2) As Double

Dim point2(0 To 2) As Double

point1(0) = 6: point1(1) = 1: point1(2) = 0

point2(0) = 6: point2(1) = 4: point2(2) = 0

MsgBox "L?y d?i x?ng du?ng da tuy?n.", , "VD Mirror"

' Th?c hi?n l?y d?i x?ng du?ng da tuy?n

Dim mirrorObj As AcadLWPolyline

Set mirrorObj = plineObj.Mirror(point1, point2)

mirrorObj.color = acRed

ZoomAll

MsgBox "Mirror completed.", , " VD Mirror"

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

Thật là khó với code như này

Nhưng bạn sai ở chỗ:

Set mirrorObj = plineObj.Mirror(point1, point2)

nghĩa là bạn chưa tạo được đối tượng plineObj nên không có thực thể đối xưng => báo sai.

Nếu bạn muốn lấy đối xứng cho toàn bộ khối trên thì đối tượng khai báo phải là kiểu AcadLine hoặc Variant

Dim mirrorObj As AcadLine

Dim mirrorObj As Variant

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

anh ơi cho em hỏi code này sai ở chỗ nào ạ

thân!

 

 

 

Private Sub CommandButton1_Click()

 

Dim lineobj As AcadLine

Dim startpoint(0 To 2) As Double

Dim endpoint(0 To 2) As Double

Dim dblRadius As Double

Dim center(0 To 2) As Double

Dim startangle As Double

Dim endangle As Double

 

startpoint(0) = 2: startpoint(1) = 1: startpoint(2) = 0

endpoint(0) = 4: endpoint(1) = 1: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

 

center(0) = 2: center(1) = 2: center(2) = 0

startangle = 180 * 3.141592654 / 180

endangle = 270 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

 

startpoint(0) = 5: startpoint(1) = 2: startpoint(2) = 0

endpoint(0) = 5: endpoint(1) = 3: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

 

center(0) = 2: center(1) = 3: center(2) = 0

startangle = 90 * 3.141592654 / 180

endangle = 180 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

 

startpoint(0) = 4: startpoint(1) = 4: startpoint(2) = 0

endpoint(0) = 2: endpoint(1) = 4: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

 

startpoint(0) = 1: startpoint(1) = 3: startpoint(2) = 0

endpoint(0) = 1: endpoint(1) = 2: endpoint(2) = 0

Set lineobj = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

 

center(0) = 4: center(1) = 3: center(2) = 0

startangle = 0 * 3.141592654 / 180

endangle = 90 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

 

center(0) = 4: center(1) = 2: center(2) = 0

startangle = 270 * 3.141592654 / 180

endangle = 360 * 3.141592654 / 180

dblRadius = 1

Set objent = ThisDrawing.ModelSpace.AddArc(center, dblRadius, startangle, endangle)

 

 

Dim hatchObj As AcadHatch

Dim patternName As String

Dim PatternType As Long

Dim bAssociativity As Boolean

patternName = "ANSI31"

PatternType = 0

bAssociativity = True

 

 

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)

Dim outerloop(0 To 7) As AcadEntity

 

startpoint(0) = 2: startpoint(1) = 1: startpoint(2) = 0

endpoint(0) = 4: endpoint(1) = 1: endpoint(2) = 0

Set outerloop(0) = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

hatchObj.AppendOuterLoop (outerloop)

 

 

startpoint(0) = 5: startpoint(1) = 2: startpoint(2) = 0

endpoint(0) = 5: endpoint(1) = 3: endpoint(2) = 0

Set outerloop(1) = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

hatchObj.AppendOuterLoop (outerloop)

 

startpoint(0) = 4: startpoint(1) = 4: startpoint(2) = 0

endpoint(0) = 2: endpoint(1) = 4: endpoint(2) = 0

Set outerloop(2) = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

hatchObj.AppendOuterLoop (outerloop)

 

startpoint(0) = 1: startpoint(1) = 3: startpoint(2) = 0

endpoint(0) = 1: endpoint(1) = 2: endpoint(2) = 0

Set outerloop(3) = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)

hatchObj.AppendOuterLoop (outerloop)

 

center(0) = 2: center(1) = 3: center(2) = 0

startangle = 90 * 3.141592654 / 180

endangle = 180 * 3.141592654 / 180

dblRadius = 1

Set outerloop(4) = ThisDrawing.ModelSpace.AcadArc(center, dblRadius, endangle, startangle)

hatchObj.AppendOuterLoop (outerloop)

 

center(0) = 2: center(1) = 2: center(2) = 0

startangle = 180 * 3.141592654 / 180

endangle = 270 * 3.141592654 / 180

dblRadius = 1

Set outerloop(5) = ThisDrawing.ModelSpace.AcadArc(center, startangle, endangle, dblRadius)

hatchObj.AppendOuterLoop (outerloop)

 

 

center(0) = 4: center(1) = 3: center(2) = 0

startangle = 0 * 3.141592654 / 180

endangle = 90 * 3.141592654 / 180

dblRadius = 1

Set outerloop(6) = ThisDrawing.ModelSpace.AcadArc(center, dblRadius, endangle, startangle)

hatchObj.AppendOuterLoop (outerloop)

 

center(0) = 4: center(1) = 2: center(2) = 0

startangle = 270 * 3.141592654 / 180

endangle = 360 * 3.141592654 / 180

dblRadius = 1

Set outerloop(7) = ThisDrawing.ModelSpace.AcadArc(center, dblRadius, endangle, startangle)

hatchObj.AppendOuterLoop (outerloop)

 

hatchObj.Evaluate

hatchObj.PatternSpace = hatchObj.PatternSpace

 

hatchObj.Evaluate

ThisDrawing.Regen True

 

 

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

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  

×