Liên kết với CAD từ Excel

[nkgedadknr 0]

 

Chào các bạn!

 

Mình đang có vấn đề này nhờ các Bạn giúp:

 

Mình đang thực hiện lấy các properties của Polyline từ Cad qua Excel bằng cách viết:

 

1. Macro Capture (Right click Popup Menu từ Excel > Capture) để chọn Polyline từ Acad. Import các properties cần thiết sang Excel.

 

Sau đó mình muốn Highlight polyline có propertities tại dòng n cùa màn hình Excel trên màn hình Acad và zoom tới vị trí Polyline đó bằng Zoom Center: giải thuật của mình là chọn tất cả entities của bản vẽ hiện tại, chọn entity nào có handle cùng với handle trên Excel thì highllight và zoom tới entity đó

 

2. Macro Highlight (Right click Popup Menu từ Excel > Hightlight)

 

Mình có attach thêm 1 bản vẽ Cad và 1 workbook Excel

 

Đối với những Polyline mình tạo ra thì macro Highlight thực thi OK: nghĩ là highlight polyline và zoom tới vị trí đó. (trên bản vẽ là layer 0)

 

Tuy nhiên, với những polyline mà mình có sẳn (layer 1) thì macro Highlight không thực hiện được.

 

Mình thấy hiện tượng như vậy. Vì trong Code của Macro Highlight mình Debug.Print tọa độ của objEnt.Coordinates thì thấy trong trường hợp layer 1 Coordinate này bằng 0 (không nhận được). Trong khi layer 0 thì objEnt.Coordinate hiểu được.

 

Các Bạn giúp mình một tay nhé. Tiện đây nhờ các bác đóng góp ý kiến cho giải thuật zoom lấy entity để highlight và Code của mình thêm hoàn thiện.

À mà mình muốn highlight entity có hiển thị các grid mày xanh ở 2 đầu và cuối polyline đó thì làm sao nhỉ

 

http://www.cadviet.com/upfiles/2/upkc121209.rar

[nkgedadknr 0]

Mình chạy mã này trên màn hình Excel (từ ribbon)

Mình muốn set focus back to Excel screen(select some cells) sau khi hide entity in Cad screen, những mã này chạy không theo ý mình, xin các Bạn giúp mình với.

 

Vấn đề trên mình đã solve được rồi

 

 

Private Sub UnHide(control As IRibbonControl)

Dim objApp As Object

Dim ExcCap As String

ExcCap = Application.Caption

 

On Error Resume Next

Set objApp = GetObject(, "AutoCAD.Application")

Dim objDoc As AcadDocument

AppActivate "AutoCAD", True

With objApp

Set objDoc = .ActiveDocument

Dim objEnt As AcadEntity

For Each objEnt In objDoc.ModelSpace

objEnt.Visible = True

Next objEnt

objDoc.Regen acAllViewports

End With

AppActivate objApp, False

Set objDoc = Nothing

Set objApp = Nothing

 

AppActivate ExcCap, True

End Sub

[nkgedadknr 0]

Nhờ các bác cao thủ giúp Em với. Em bí cái này mãi mà không được

[anhcos 196]

Nhưng tới cuối cùng vẫn không biết bạn bí cái gì.

Bạn ra câu hỏi sau đó nói là giải quyết được rồi mà.

[nkgedadknr 0]

Nhưng tới cuối cùng vẫn không biết bạn bí cái gì.

Bạn ra câu hỏi sau đó nói là giải quyết được rồi mà.

 

Em bí cái này ạ:

Em không thể quay về màn hình Excel (activate) bằng appactivate sao khi thao tác trên Cad. Cursor vẫn hiện trên Cad

http://www.cadviet.com/upfiles/2/setfocusexcel.jpg

 

Private Sub UnHide(control As IRibbonControl)

Dim objApp As Object

Dim ExcCap As String

ExcCap = Application.Caption

 

On Error Resume Next

Set objApp = GetObject(, "AutoCAD.Application")

Dim objDoc As AcadDocument

AppActivate "AutoCAD", True

With objApp

Set objDoc = .ActiveDocument

Dim objEnt As AcadEntity

For Each objEnt In objDoc.ModelSpace

objEnt.Visible = True

Next objEnt

objDoc.Regen acAllViewports

End With

AppActivate objApp, False

Set objDoc = Nothing

Set objApp = Nothing

 

[color=#FF0000][u][b]AppActivate ExcCap, True[/b][/u][/color]

End Sub

[code/]

[anhcos 196]

Em bí cái này ạ:

Em không thể quay về màn hình Excel (activate) bằng appactivate sao khi thao tác trên Cad. Cursor vẫn hiện trên Cad

http://www.cadviet.com/upfiles/2/setfocusexcel.jpg

 

Private Sub UnHide(control As IRibbonControl)

Dim objApp As Object

Dim ExcCap As String

ExcCap = Application.Caption

 

On Error Resume Next

Set objApp = GetObject(, "AutoCAD.Application")

Dim objDoc As AcadDocument

AppActivate "AutoCAD", True

With objApp

Set objDoc = .ActiveDocument

Dim objEnt As AcadEntity

For Each objEnt In objDoc.ModelSpace

objEnt.Visible = True

Next objEnt

objDoc.Regen acAllViewports

End With

AppActivate objApp, False

Set objDoc = Nothing

Set objApp = Nothing

 

[color=#ff0000][u][b]AppActivate ExcCap, True[/b][/u][/color]

End Sub

[code/]

 

Bạn dùng biến ExcelObj đại diện cho Excel, AcadApp đại diện cho Acad

 

Bạn cần thiết lập liên kết tương ứng

Set ExcelObj = GetObject(, "Excel.Application")

và

Set AcadObj = GetObject(, "ACAD.Application")

 

Sau đó muốn activate thằng nào thì dùng hàm sau

AppActivate AppObj.Caption

 

Trong đó AppObj là biến liên kết với chương trình Excel, ACAD hay Word hay bất kỳ chương trình nào có thông qua quá trình cài đặt trên PC.

 

Caption là biến đại diện cho tiêu đề của cửa sổ chương trình đang liên kết. Caption sử dụng để tương thích ngược.

[nkgedadknr 0]

Bạn dùng biến ExcelObj đại diện cho Excel, AcadApp đại diện cho Acad

 

Bạn cần thiết lập liên kết tương ứng

Set ExcelObj = GetObject(, "Excel.Application")

và

Set AcadObj = GetObject(, "ACAD.Application")

 

Sau đó muốn activate thằng nào thì dùng hàm sau

AppActivate AppObj.Caption

 

Trong đó AppObj là biến liên kết với chương trình Excel, ACAD hay Word hay bất kỳ chương trình nào có thông qua quá trình cài đặt trên PC.

 

Caption là biến đại diện cho tiêu đề của cửa sổ chương trình đang liên kết. Caption sử dụng để tương thích ngược.

 

 

Cảm ơn Bạn.

 

Mình đã đặt lại tên Application theo như ý Bạn. Tuy nhiên khi chuyển qua Appactivate EXCELApp.Caption thì cursor vẫn hiển thị trên màn hình CAD, mình phải di chuyển qua màn hình Excel và Click thì mới Activate được Excel

[anhcos 196]

Ví dụ đơn giản về active Excel:

Trong trường hợp Excel đã khởi động, hàm sau làm việc tốt

 

Sub test()

Dim ExcelObj As Object

Set ExcelObj = GetObject(, "Excel.Application")

AppActivate ExcelObj.Caption

Set ExcelObj = Nothing

End Sub

 

Hàm GetObject sẽ liên kết với đối tượng có cùng class và được khởi động đầu tiên nhất.

Trong trường hợp của bạn có thể hàm GetObject đã liên kết với một bản Excel đang chạy ở background.

Bạn kiểm tra trong Task Manager xem có một bản Excel nào đang chạy không.

Để chắc ăn hơn, kèm theo lệnh sau:

 

Set ExcelObj = GetObject(, "Excel.Application")

Excel.Visible = True

Sẽ làm cho bản Excel đang chạy ở background trở thành foreground

[anhcos 196]

Tớ có mấy cái tiện ích, hôm nào đem ra cho mọi người xài.

[nkgedadknr 0]

Tớ có mấy cái tiện ích, hôm nào đem ra cho mọi người xài.

 

Bác thật chính xác như thần, không biết tại sao Em mở Tasl Manager lên lại có 2 Excel, vậy là thế nào hở bác, Em xài Excel 2007, kết hợp với cad 2010.

Lúc trước em chạy macro xuất từ cad sang excel thì cũng gặp th này 2 excel chạy song song nhưng em ko quan tâm

nhưng giờ em chạy từ excel sang cad thì vâp phải cái này. Xin cao kiến Bác???

Mai Em lên VP up cái hình đó cho Bác xem ạ

Em có nhu cầu viết tiện ích vba, chắc hôm nào xin bác chút thời gian được không ạ? E ở SG

[KVT 0]

Bác thật chính xác như thần, không biết tại sao Em mở Tasl Manager lên lại có 2 Excel, vậy là thế nào hở bác, Em xài Excel 2007, kết hợp với cad 2010.

Lúc trước em chạy macro xuất từ cad sang excel thì cũng gặp th này 2 excel chạy song song nhưng em ko quan tâm

nhưng giờ em chạy từ excel sang cad thì vâp phải cái này. Xin cao kiến Bác???

Mai Em lên VP up cái hình đó cho Bác xem ạ

Em có nhu cầu viết tiện ích vba, chắc hôm nào xin bác chút thời gian được không ạ? E ở SG

 

Bạn thử đưa đoạn mã đó lên để mọi người xem thử.

[phantuhuong 217]

Bác thật chính xác như thần, không biết tại sao Em mở Tasl Manager lên lại có 2 Excel

oo

 

Lỗi của chương trình là dùng CreateObject để mở Excel. Phải dùng GetObject trước vì trong trường hợp Excel đã mở thì nó sẽ không mở thêm.

 

Code để tham khảo đây:

 

Sub KhoidongExcel()
 On Error Resume Next  'Bo qua loi khi Excel chua mo
'Khi Excel dang mo
Set ExcelApp = GetObject(, "Excel.Application")
  'Khi Excel chua mo thi mo r
  If Err Then
	Err.Clear
	Set ExcelApp = CreateObject("Excel.Application")
  End If

ExcelApp.Visible = True
AppActivate AutoCAD.Caption
Set ExcelApp =NOTHING
End Sub

[CDung_k47 36]

Bác Phantuhuong cho em hỏi chút,đây là đoạn code tạo Hatch bằng VBA em tìm được trên google tác giả là bác post lên,đoạn code này tạo Hatch cho nửa đường tròn.Em thực hành tạo Hatch cho 1 vùng khác nhưng làm mãi không được,kiến thức còn hạn hẹp,mong bác và các cao thủ trong diễn đàn chỉ giùm.

Sub Example_AppendInnerLoop()
' This example creates an associative hatch in model space.

Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
Dim DiemP(0 To 2) As Double

' Define the hatch
patternName = "ANSI31"
PatternType = 0
bAssociativity = True

' Create the associative Hatch object
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)

' Create the outer loop for the hatch.
' An arc and a line are used to create a closed loop.

Dim outerLoop(0 To 1) As AcadEntity
Dim center(0 To 2) As Double
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
center(0) = 5: center(1) = 3: center(2) = 0
DiemP(0) = 2.5: DiemP(1) = 3.5
radius = 3
startAngle = 0
endAngle = 3.141592
Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
Set outerLoop(1) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(0).EndPoint)

' Append the outer loop to the hatch object
hatchObj.AppendOuterLoop (outerLoop)

' Append a circle as the inner loop for the hatch.
Dim innerLoop(0) As AcadEntity
Dim innerLoop1(0) As AcadEntity
center(0) = 5: center(1) = 4.5: center(2) = 0
radius = 1
Set innerLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
Set innerLoop1(0) = ThisDrawing.ModelSpace.AddText("PTH", DiemP, 0.2)
hatchObj.AppendInnerLoop (innerLoop)
hatchObj.AppendInnerLoop (innerLoop1)

' Evaluate and display the hatch
hatchObj.Evaluate
ThisDrawing.Regen True

End Sub