High light entity in Cad screen from Excel

[nkgedadknr]

Hi All!

 

I have a bit trouble with this

 

I try to get Polyline properties from Cad pass to Excel by:

 

1. Macro Capture (Right click Popup Menu from Excel > Capture) to select Polyline in Acad. Import required properties to Excel.

 

Then, I make Highlight polyline with propertities located at row n (Excel screen) in Acad screen and zoom to Polyline location by Zoom Center: My alorythm is to select all entities in active drawing, select entity that has same handle with one in Excel > highllight and zoom to

 

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

 

I attach a workbook and a drawing

 

For Polyline that I draw by myself, macro Highlight do well: ie. highlight polyline and zoom correctly. (in my drawing is layer 0)

 

Otherwise, for polyline I convert from existing line (layer 1) macro Highlight can not do properly

 

I verify this by Debug.print objEnt.Coordinates in Macro Highlight

 

Please help me this trouble.

And other, how can I highlight a entity with grid on at 2 ends and center of an entity?

 

This my link :Hi All!

 

I have a bit trouble with this

 

I try to get Polyline properties from Cad pass to Excel by:

 

1. Macro Capture (Right click Popup Menu from Excel > Capture) to select Polyline in Acad. Import required properties to Excel.

 

Then, I make Highlight polyline with propertities located at row n (Excel screen) in Acad screen and zoom to Polyline location by Zoom Center: My alorythm is to select all entities in active drawing, select entity that has same handle with one in Excel > highllight and zoom to

 

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

 

I attach a workbook and a drawing

 

For Polyline that I draw by myself, macro Highlight do well: ie. highlight polyline and zoom correctly. (in my drawing is layer 0)

 

Otherwise, for polyline I convert from existing line (layer 1) macro Highlight can not do properly

 

I verify this by Debug.print objEnt.Coordinates in Macro Highlight

 

Please help me this trouble.

And other, how can I highlight a entity with grid on at 2 ends and center of an entity?

 

HTis my link :

.cadviet.com/upfiles/2/upkc121209.rar

[SEANT]

You are better off doing this:

 

 

. . . . . .
   ma = Range("H" & dong).Value
   AppActivate "AutoCAD", True
With objApp
   Set objDoc = .ActiveDocument
   Dim objEnt As [color="DarkRed"]AcadEntity[/color]
   For Each objEnt In objDoc.ModelSpace
       If objEnt.Handle = ma Then
           objEnt.Highlight True
. . . . . .

 

If not, an error is generated whenever the routine encounters an entity other than a polyline. It just so happens that the Poly’s on layer 0 are processed before that error is encountered.

[nkgedadknr]

Thanks SEANT but it doesn't work

[SEANT]

As a general note, “On Error Resume Next” can be useful in areas where a programmer expects errors and needs to take steps to accommodate them. Leaving the “On Error Resume Next” active, however, will make debugging unexpected errors quite difficult. That “On Error” call should be followed by an “On Error Goto 0” as soon as possible.

 

The modification I suggested does address one problem hidden by the situation just described. There may be additional problems; you will have to describe what does and doesn’t work more explicitly to allow us to offer useful suggestions.

[nkgedadknr]

Thanks SEANT so much, it works now,

 

Another question concerns:

 

I want to Zoom to Entity on Cad screen but my Zoom Center code doesn't work well, i think the problem go with the magnification.

 

How can we choose the correct magnification adapted to desired object for zooming ?

[SEANT]

Here are some code modifications demonstrating how to zoom to a particular entity. These mods also show an alternate way of retrieving entities via their handles.

 

As is commonly the case with example code, there is limited error checking and testing. Use with caution.

 

Option Explicit
Private Sub Highlight()
   Dim objApp As Object
   On Error Resume Next
   Set objApp = GetObject(, "AutoCAD.Application")
   If Err.Number <> 0 Then Err.Clear: Exit Sub
   On Error GoTo 0
   Dim objDoc As AcadDocument
   Dim ma As String
   Dim dong As Integer
   dong = ActiveCell.Row
   ma = Range("H" & dong).Value
   AppActivate "AutoCAD", True
With objApp
   Set objDoc = .ActiveDocument
   Dim objEnt As AcadEntity
   Dim varMin, varMax As Variant
   Set objEnt = objDoc.HandleToObject(ma) 'alternative to searching drawing database
   objEnt.Highlight True
   objEnt.GetBoundingBox varMin, varMax
   Dim magnification As Double
   magnification = CDbl(Range("J" & dong).Value)
   ZoomWindow varMin, varMax
   ZoomScaled magnification, acZoomScaledRelative
End With
End Sub
Sub Capture()
   Dim objApp As Object
   Dim ExcCap As String
   ExcCap = Application.Caption
   On Error Resume Next
   Set objApp = GetObject(, "AutoCAD.Application")
   If Err.Number <> 0 Then
       Err.Clear
       On Error GoTo ErrHandler
       Set objApp = CreateObject("AutoCAD.Application")
   End If
   On Error GoTo 0
With objApp
  .Visible = True
   .WindowState = acNorm
   .ZoomExtents
   Dim objDoc As AcadDocument
   Set objDoc = .ActiveDocument
End With
   
With objDoc
   Dim oSset As AcadSelectionSet
   Dim oEnt As AcadEntity
   Dim oLWPline As AcadLWPolyline
   Dim intCodes(3) As Integer
   Dim varCodeValues(3) As Variant
   Dim dxfCode, dxfData
   Dim i As Integer
   Dim SetName As String
   intCodes(0) = -4: varCodeValues(0) = "<and"
   intCodes(1) = 8:  varCodeValues(1) = objDoc.ActiveLayer.Name
   intCodes(2) = 0:  varCodeValues(2) = "LWPOLYLINE"
   intCodes(3) = -4: varCodeValues(3) = "and>"
   dxfCode = intCodes
   dxfData = varCodeValues
   SetName = "$Poly$"
    
   For i = 0 To objDoc.SelectionSets.Count - 1
   If objDoc.SelectionSets.Item(i).Name = SetName Then
       objDoc.SelectionSets.Item(i).Delete
       Exit For
   End If
   Next i
   
   Set oSset = objDoc.SelectionSets.Add(SetName)
   oSset.SelectOnScreen dxfCode, dxfData
   DoEvents
   i = 2
   With Application.ActiveSheet
       .Cells(1, 1) = "No."
       .Cells(1, 2) = "Layer"
       .Cells(1, 3) = "Nos"
       .Cells(1, 4) = "Lengh"
       .Cells(1, 5) = "Height"
       .Cells(1, 6) = "Multiply"
       .Cells(1, 7) = "Sub-total"
       .Cells(1,  = "Handle"
       .Cells(1, 9) = "Type"
       .Cells(1, 10) = "ZoomScale"
       For Each oEnt In oSset
           Set oLWPline = oEnt
           .Cells(i, 1).Formula = "=MAX($A$1:A" & i - 1 & ") + 1"
           .Cells(i, 2) = oLWPline.Layer
           .Cells(i, 3) = ""
           .Cells(i, 4) = Round(oLWPline.Length * 10 ^ -3, 2)
           .Cells(i, 5) = ""
           .Cells(i, 6) = ""
           .Cells(i, 7).Formula = "=PRODUCT(RC[-4]:RC[-1])"
           .Cells(i,  = oLWPline.Handle
           .Cells(i, 9) = Replace(oLWPline.ObjectName, "AcDb", "", 1, -1)
           .Cells(i, 10) = 0.5
           i = i + 1
       Next
       .Cells(1, 1).Select
   End With
End With
   
   DoEvents
   AppActivate ExcCap, True
   
ErrHandler:
   Set objDoc = Nothing
   Set objApp = Nothing
   On Error GoTo 0
End Sub