Chuyển đến nội dung
Diễn đàn CADViet
phantuhuong

Ứng dụng VBA Automation trong việc trao đổi dữ liệu giữa Excel với Autocad

Bởi phantuhuong , trong Lập trình khác

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

mechatronics    0

mechatronics
Đã đăng

Để so sánh giữa 2 môi trường, tôi thực hiện bài toán đơn giản nhất cho dễ hiểu. Hai thủ tục viết trong Excel và AutoCad như sau:

 

 

Trong Excel

Public AcadApp As AcadApplication

Sub Hinh_Tru_Excel()
Dim i As Integer
Dim AcadMo As AcadModelSpace
Dim AcadUt As AcadUtility
Dim DiemDauP As Variant		     'Diem dau tien de ve
Dim DiemBaoP(0 To 11) As Double     'Diem bao phan to mat cat
'Khai bao ghi ky hieu Ten lop
Dim GhiTenlopP(0 To 2) As Double
Dim Tenlop As String
Dim TenlopT As AcadText
'Khai bao ghi do sau lop
Dim GhiDosauP(0 To 2) As Double
Dim DosauT As AcadText
'Khai bao To mat cat
Dim MatcatH As AcadHatch
Dim VongbaoPL(0) As AcadPolyline
'Khai bao noi dung Hinh tru
Dim HinhTruP(0 To 2) As Double
Dim HinhTruT As AcadText
'Khai bao ty le dung Hinh tru
Dim TLdung As Single
Dim TLdungP(0 To 2) As Double
Dim TLdungT As AcadText
'Khai bao chieu rong cua phan To ky hieu dia tang va Pi
Const Chieurong = 10:  Const Pi = 3.14159
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Call KhoidongAutoCad
'Thiet lap font ".VnArial" cho kieu "Standard"
Set TxtStyleObj = AcadApp.ActiveDocument.TextStyles.Item("Standard")
	TxtStyleObj.SetFont ".VnArial", False, False, 0, 34
'Xac dinh Ty le dung
TLdung = Val(ThisWorkbook.Sheets("Khai bao").Range("J3"))
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set AcadMo = AcadApp.ActiveDocument.ModelSpace
Set AcadUt = AcadApp.ActiveDocument.Utility
DiemDauP = AcadUt.GetPoint(, "Vao vi tri dau tien:")
'Ghi noi dung ten Hinh tru va Ty le dung
HinhTruP(0) = DiemDauP(0) + 8
HinhTruP(1) = DiemDauP(1) + 4
Set HinhTruT = AcadMo.AddText("HINH TRU HO KHOAN", HinhTruP, 1.5)
TLdungP(0) = HinhTruP(0) + 5
TLdungP(1) = HinhTruP(1) - 2.5
Set TLdungT = AcadMo.AddText("Tû lÖ ®øng: 1/" & TLdung, TLdungP, 1)
	TLdungT.ObliqueAngle = 0.15
DiemBaoP(0) = DiemDauP(0)
DiemBaoP(1) = DiemDauP(1)
'Tao vong lap duyet qua tung lop
With ThisWorkbook.Worksheets("Khai bao").Range("B2")
	i = 1
	Do
		'Xac dinh do chenh sau giua cac lop dat
		Chenhsau = (.Offset(i - 1, 1) - .Offset(i, 1)) * 1000 / TLdung
		'Xac dinh cac diem bao va ve duong Polyline
		DiemBaoP(3) = DiemBaoP(0) + Chieurong: DiemBaoP(4) = DiemBaoP(1)
		DiemBaoP(6) = DiemBaoP(3): DiemBaoP(7) = DiemBaoP(4) + Chenhsau
		DiemBaoP(9) = DiemBaoP(6) - Chieurong: DiemBaoP(10) = DiemBaoP(7)
		Set VongbaoPL(0) = AcadMo.AddPolyline(DiemBaoP)
			VongbaoPL(0).Closed = True  'Kep kin duong Polyline
			VongbaoPL(0).Color = acRed
		'Ghi ten cac lop dat
		GhiTenlopP(0) = DiemBaoP(3) + 2
		GhiTenlopP(1) = DiemBaoP(4) + Chenhsau / 2
		Tenlop = "Líp " & .Offset(i, 0) & ": " & .Offset(i, 2)
		Set TenlopT = AcadMo.AddText(Tenlop, GhiTenlopP, 0.8)
		'Ghi do sau lop
		GhiDosauP(0) = DiemBaoP(6) + 0.5
		GhiDosauP(1) = DiemBaoP(7)
		Set DosauT = AcadMo.AddText(FormatNumber(.Offset(i, 1), 1), GhiDosauP, 1)
			DosauT.Color = acRed
		'To ky hieu mat cat dia tang
		Set MatcatH = AcadMo.AddHatch(1, .Offset(i, 4), True)
			MatcatH.PatternScale = .Offset(i, 5)
			MatcatH.PatternAngle = .Offset(i, 6) * Pi / 180
			MatcatH.AppendOuterLoop (VongbaoPL)
			MatcatH.Evaluate: MatcatH.Update
		'Gan diem de sang lop moi
		DiemBaoP(0) = DiemBaoP(9)
		DiemBaoP(1) = DiemBaoP(10)

		i = i + 1
	Loop Until IsEmpty(.Offset(i, 0))
End With
AcadApp.ZoomAll
'Xoa bo bien doi tuong
Set AcadApp = Nothing
Set AcadMo = Nothing
Set AcadUt = Nothing
End Sub

 

Trong AutoCad

 

Public ExcelApp As Excel.Application
Public Const Tenfile = "D:\Khoahoc2008\Hinhtru.xls"

Sub VeHinhTru_AutoCad()
Dim i As Integer
Dim AcadMo As AcadModelSpace
Dim AcadUt As AcadUtility
Dim DiemDauP As Variant		     'Diem dau tien de ve
Dim DiemBaoP(0 To 11) As Double     'Diem bao phan to mat cat
'Khai bao ghi ky hieu Ten lop
Dim GhiTenlopP(0 To 2) As Double
Dim Tenlop As String
Dim TenlopT As AcadText
'Khai bao ghi do sau lop
Dim GhiDosauP(0 To 2) As Double
Dim DosauT As AcadText
'Khai bao To mat cat
Dim MatcatH As AcadHatch
Dim VongbaoPL(0) As AcadPolyline
'Khai bao noi dung Hinh tru
Dim HinhTruP(0 To 2) As Double
Dim HinhTruT As AcadText
'Khai bao ty le dung Hinh tru
Dim TLdung As Single
Dim TLdungP(0 To 2) As Double
Dim TLdungT As AcadText
'Khai bao chieu rong cua phan To ky hieu dia tang va Pi
Const Chieurong = 10:  Const Pi = 3.14159
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Khoi dong Excel
Call KhoidongExcel
TLdung = Val(ExcelApp.Sheets("Khai bao").Range("J3"))
'Thiet lap font ".VnArial" cho kieu "Standard"
Set TxtStyleObj = ActiveDocument.TextStyles.Item("Standard")
	TxtStyleObj.SetFont ".VnArial", False, False, 0, 34
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set AcadMo = ActiveDocument.ModelSpace
Set AcadUt = ActiveDocument.Utility
DiemDauP = AcadUt.GetPoint(, "Vao vi tri dau tien:")
'Ghi noi dung ten Hinh tru va Ty le dung
HinhTruP(0) = DiemDauP(0) + 8
HinhTruP(1) = DiemDauP(1) + 4
Set HinhTruT = AcadMo.AddText("HINH TRU HO KHOAN", HinhTruP, 1.5)
TLdungP(0) = HinhTruP(0) + 5
TLdungP(1) = HinhTruP(1) - 2.5
Set TLdungT = AcadMo.AddText("Tû lÖ ®øng: 1/" & TLdung, TLdungP, 1)
	TLdungT.ObliqueAngle = 0.15
DiemBaoP(0) = DiemDauP(0)
DiemBaoP(1) = DiemDauP(1)

With ExcelApp.Worksheets("Khai bao").Range("B2")

	'Tao vong lap qua tung diem
	i = 1
	Do
		'Xac dinh do chenh sau giua cac lop dat
		Chenhsau = (.Offset(i - 1, 1) - .Offset(i, 1)) * 1000 / TLdung
		'Xac dinh cac diem bao va ve duong Polyline
		DiemBaoP(3) = DiemBaoP(0) + Chieurong: DiemBaoP(4) = DiemBaoP(1)
		DiemBaoP(6) = DiemBaoP(3): DiemBaoP(7) = DiemBaoP(4) + Chenhsau
		DiemBaoP(9) = DiemBaoP(6) - Chieurong: DiemBaoP(10) = DiemBaoP(7)
		Set VongbaoPL(0) = AcadMo.AddPolyline(DiemBaoP)
			VongbaoPL(0).Closed = True  'Kep kin duong Polyline
			VongbaoPL(0).color = acRed
		'Ghi ten cac lop dat
		GhiTenlopP(0) = DiemBaoP(3) + 2
		GhiTenlopP(1) = DiemBaoP(4) + Chenhsau / 2
		Tenlop = "Líp " & .Offset(i, 0) & ": " & .Offset(i, 2)
		Set TenlopT = AcadMo.AddText(Tenlop, GhiTenlopP, 0.8)
		'Ghi do sau lop
		GhiDosauP(0) = DiemBaoP(6) + 0.5
		GhiDosauP(1) = DiemBaoP(7)
		Set DosauT = AcadMo.AddText(FormatNumber(.Offset(i, 1), 1), GhiDosauP, 1)
			DosauT.color = acRed
		'To ky hieu mat cat dia tang
		Set MatcatH = AcadMo.AddHatch(1, .Offset(i, 4), True)
			MatcatH.PatternScale = .Offset(i, 5)
			MatcatH.PatternAngle = .Offset(i, 6) * Pi / 180
			MatcatH.AppendOuterLoop (VongbaoPL)
			MatcatH.Evaluate: MatcatH.Update
		'Gan diem de sang lop moi
		DiemBaoP(0) = DiemBaoP(9)
		DiemBaoP(1) = DiemBaoP(10)

		i = i + 1
	Loop Until IsEmpty(.Offset(i, 0))
End With
ZoomAll
'Xoa bo bien doi tuong
Set ExcelApp = Nothing
Set AcadMo = Nothing
Set AcadUt = Nothing

End Sub

 

Các bạn sẽ thấy hai thủ tục trên giống nhau như 2 chị em sinh đôi! Chính vì vậy bạn sẽ không bị bỡ ngỡ khi chuyển đổi môi trường lập trình VBA

 

 

Hinh12.jpg

Hình 12: Kết quả vẽ hình trụ hố khoan và một số đối tượng vẽ chính

 

 

Một số đối tượng chính trong thủ tục trên được mô tả trong kết quả vẽ hình trụ hố khoan tại hình 12. Trong đó, những đối tượng trong AutoCad quy ước có đuôi chữ hoa P là point, PL là polyline, T là text, L là line,...

 

3. Kết luận

 

- Chức năng Automation giúp chúng ta xây dựng các chương trình có khả năng tự động hoá trao đổi dữ liệu giữa các môi trường khác nhau. Sự kết hợp giữa Excel, AutoCad cùng với ngôn ngữ lập trình VBA tích hợp bên trong có thể giải quyết được nhiều bài toán phức tạp khác nhau trong lĩnh vực kỹ thuật.

- Giống như VB6, VBA là ngôn ngữ lập trình tiện dụng phát triển trong nhiều ứng dụng, có khả năng ứng dụng mạnh mẽ trong nhiều ngành nghề, cần được quan tâm đúng mức trong việc dạy và học tin học ứng dụng không chuyên trong các trường Đại học.

 

sao hình ảnh lỗi hết vậy bạn. t chẳng xem dc gì cả. hix

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

p.bavinh    1

p.bavinh
Đã đăng

Tôi có một số code về vba có thể liên hệ giữa autocad và excel. Nếu anh em nào muốn có thể liên lạc với tôi tôi sẽ cho :).

yahoo: phambavinh_ht

email: bavinh.bavinh@gmail.com

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

nguyendan81985    3

nguyendan81985
Đã đăng

cho mình hỏi. làm thế nào để lấy dữ liệu từ Excel để xử lý trong CAD

mình ví dụ thế này: trong VBA CAD có các textbox là L1, L2, L3

trong excel có các cột L1, L2, L3 ở các vị trí A1, B1, C1 tương ứng. vậy làm thế nào để CAD là để gán giá trị từ excel cho CAD. 

chương trình trong CAD có thể đơn giản làm 1 cái msgbox hiển thị giá trị trong cột L1,L2, L3 ....

 

bạn nào biết chỉ giúp nhé. thanks

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

dinhvantrang
Đã đăng

cho mình hỏi. làm thế nào để lấy dữ liệu từ Excel để xử lý trong CAD

mình ví dụ thế này: trong VBA CAD có các textbox là L1, L2, L3

trong excel có các cột L1, L2, L3 ở các vị trí A1, B1, C1 tương ứng. vậy làm thế nào để CAD là để gán giá trị từ excel cho CAD. 

chương trình trong CAD có thể đơn giản làm 1 cái msgbox hiển thị giá trị trong cột L1,L2, L3 ....

 

bạn nào biết chỉ giúp nhé. thanks

Bạn phải kết nối giữa AutoCad và Excel lại với nhau thì mới lấy dữ liệu qua lại với nhau dc.

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

dinhvantrang
Đã đăng

Mình cần học lớp lập trình ứng dụng VBA để lien kết CAD và exell, bạn nào biết ở đâu mở lớp xin chỉ giúp mình.

Nếu cần thì mình dạy online cho bạn nhé.

Add skype mình: dinhvantrang73 hoặc inbox mail: dinhvantrang73@gmail.com

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    230

phantuhuong
Đã đăng

Rất vui là nội dung kết nối này đã được nhiều bạn áp dụng trong việc kết nối giữa 2 môi trường Excel và AutoCad. Nhờ khả năng này mà công việc được tự động hóa với kết quả chính xác cao.

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

pdhuyxn2    8

pdhuyxn2
Đã đăng

Nhờ Các Cao thủ sửa lỗi giúp em với:

Trước em sử dụng add-in trên cad2008 và excel 2003 trên win 7 32bít. Bây giờ sử dụng cad2017 và excel 2016 trên win 64 bị lỗi không sử dụng được. Kính nhờ Các Bác Giúp em với. Em cám ơn ạ!

didg.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

pdhuyxn2    8

pdhuyxn2
Đã đăng
Vào lúc 12/3/2019 tại 09:55, pdhuyxn2 đã nói:

Nhờ Các Cao thủ sửa lỗi giúp em với:

Trước em sử dụng add-in trên cad2008 và excel 2003 trên win 7 32bít. Bây giờ sử dụng cad2017 và excel 2016 trên win 64 bị lỗi không sử dụng được. Kính nhờ Các Bác Giúp em với. Em cám ơn ạ!

didg.rar

Nhờ Các Cao thủ sửa lỗi giúp em với ạ!

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

pdhuyxn2    8

pdhuyxn2
Đã đăng
Vào lúc 12/3/2019 tại 09:55, pdhuyxn2 đã nói:

Nhờ Các Cao thủ sửa lỗi giúp em với:

Trước em sử dụng add-in trên cad2008 và excel 2003 trên win 7 32bít. Bây giờ sử dụng cad2017 và excel 2016 trên win 64 bị lỗi không sử dụng được. Kính nhờ Các Bác Giúp em với. Em cám ơn ạ!

didg.rar

Nhờ các bác chỉnh giúp!

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

dinhvantrang
Đã đăng

Bạn có thể post lỗi lên đây được không? Với lại fil Add-In này có pass, bạn có thể inbox mình pass để mình xem qua cho nhé

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

pdhuyxn2    8

pdhuyxn2
Đã đăng
Vào lúc 14/4/2019 tại 21:11, dinhvantrang đã nói:

Bạn có thể post lỗi lên đây được không? Với lại fil Add-In này có pass, bạn có thể inbox mình pass để mình xem qua cho nhé

 Nhờ Các Bác trên diễn đàn chỉnh sửa giúp sử dụng cad2017 và excel 2016 trên win 64 với ạ.

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

pdhuyxn2    8

pdhuyxn2
Đã đăng
Vào lúc 14/4/2019 tại 21:11, dinhvantrang đã nói:

Bạn có thể post lỗi lên đây được không? Với lại fil Add-In này có pass, bạn có thể inbox mình pass để mình xem qua cho nhé

 Cài cad2017 và excel 2003 vẫn sử dụng bình thường sang excel 2016 thì bị lỗi ?

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

pdhuyxn2    8

pdhuyxn2
Đã đăng

kHÔNG BIẾT LỖI DO ĐÂU MÀ KHÔNG CHAY ĐƯỢC EXCEL2016

Sub text2xls()

  'Dim sset As AcadSelectionSet

  Dim texts()

  Dim lines()

  Dim gpCode(0) As Integer   'filter code

  Dim dataValue(0) As Variant

  On Error Resume Next

  Set acadapp = GetObject(, "AutoCAD.Application")        'autocadÁöÁ¤

  If Err Then

    MsgBox "AutoCAD¸¦ ½ÇÇàÇØ ÁÖ¼¼¿ä"

    End

  End If

  Set acaddoc = acadapp.ActiveDocument    'ÇöÀç document ÁöÁ¤

  Set acadutil = acaddoc.Utility   'utilityÁöÁ¤

  acadapp.Visible = True

  AppActivate acadapp.Caption                    'ijµå¸¦ È°¼ºÈ­

  

  gpCode(0) = 0           'filter ÄÚµå : entity type

  dataValue(0) = "Text" ' filter value : "Text"

  If acaddoc.SelectionSets.Count <> 0 Then acaddoc.SelectionSets("sset1").Delete

  Set sset = acaddoc.SelectionSets.Add("sset1")

  On Error Resume Next

  sset.SelectOnScreen gpCode, dataValue

  If Err Or sset.Count = 0 Then

    AppActivate ActiveWorkbook.Application.Caption

    MsgBox "Text¸¦ ¼±ÅÃÇØÁÖ¼¼¿ä"

    End

  End If

  ReDim texts(sset.Count - 1)

 

  For I = 0 To sset.Count - 1

    Set texts(I) = sset.Item(I)

  Next I

 

  

  

  sort_entityxy texts, sp, nrows  'text¸¦ xy¹æÇâÀ¸·Î Á¤·ÄÇϱâ

  msg = vbCrLf & CStr(UBound(texts) + 1) & " texts found, " & CStr(nrows) & " Lines found" & vbCrLf & "Select virtical lines"

        

  

  If Left(acadapp.Version, 2) = "14" Then

      AppActivate ActiveWorkbook.Application.Caption

      MsgBox msg

    Else

      acadutil.Prompt msg

  End If

  

 

  If UBound(sp) > 0 Then  ' ¿©·¯ÁÙÀÏ ¶§

  

      If sp(0) > 1 Then  '¿©·¯Ä÷³ÀÏ ¶§. ÇÑÄ÷³ÀÏ ¶§´Â ¾Æ¹«°Íµµ ÇÏÁö ¾ÊÀ½

        

        gpCode(0) = 0           'filter ÄÚµå : entity type

        dataValue(0) = "Line" ' filter value : "Text"

        If acaddoc.SelectionSets.Count <> 0 Then acaddoc.SelectionSets("sset1").Delete

        Set sset = acaddoc.SelectionSets.Add("sset1")

        AppActivate acadapp.Caption

        On Error Resume Next

        sset.SelectOnScreen gpCode, dataValue

        If Err Or sset.Count = 0 Then

          AppActivate ActiveWorkbook.Application.Caption

          MsgBox "¼¿À» ±¸ºÐÇϱâ À§ÇÑ ¼öÁ÷¼±À» ¼±ÅÃÇØÁÖ¼¼¿ä"

          End

        End If

        ReDim lines(sset.Count - 1)

  

        For I = 0 To sset.Count - 1

          Set lines(I) = sset.Item(I)

        Next I

 

        get_sepx_lines lines, sepxa   'lineÀÇ ½ÃÀÛÁ¡À» ÀÌ¿ëÇÏ¿© Ä÷³±¸ºÐ¼± ±¸Çϱâ

        

      End If

      

    Else   'ÇÑÁÙÀ϶§

    

      get_sepx_txts texts, sp, sepxa  'ùÁÙ text¸¦ ÀÌ¿ëÇÏ¿© Ä÷³±¸ºÐ¼± ±¸Çϱâ

      

  End If

 

 

  put2sheet texts, sp, sepxa  'ÁÖ¾îÁø text¸¦ ÁÙ(sp), Ä­(sepxa) Á¤º¸¿¡ ¬Ãç¼­ sheet¿¡ ³Ö±â

 

End Sub

image.png

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
Về Đầu Trang Lập trình khác
×