Code Red > VB(A)

Both way link between Excel and AutoCad

<< < (6/6)

VELI555:
I have another question about the code you sent me ChuckHardin. When I move the block in AutoCad dwg. I get this error message"type mismatch" and the part of the code which the VBA marks incorrect is this:

Dim objBlkRef As AcadBlockReference
        Dim varInsPnt As Variant
        Dim strHandle As String
        Dim UpdateExcel As Variant

'Existing Entity
'Should be in Excel File
        If TypeOf Object Is AcadBlockReference Then
            Set objBlkRef = Object
            varInsPnt = objBlkRef.InsertionPoint
            strHandle = objBlkRef.Handle
            If UpdateExcel(strHandle, varInsPnt, "Existing") = False Then
            Debug.Print "There was an Error Updating Excel"
           
        'MsgBox ("blokkia muutettiin")
        End If
        End If
End Sub

 Can you tell me what should be the contents of these variants:  varInsPnt and strHandle? I also attached a picture where you can see the values of those variables. In that picture, I think that the varInsPnt(0) is X-coordinate (or Y) and the varInsPnt(2) is Y-coordinate (or X I am not sure) so the varInsPnt(3) must bee Z-coordinate. the strHandle must bee the handle of the block but why is the UpdateExcel empty? Can you also tell me what means the entity in Excel (I mean this comment here: 'Existing Entity 'Should be in Excel File) and which kind of form the information should be in Excel? I hope you understand what I mean.

ChuckHardin:
UpdateExcel(strHandle, varInsPnt, "Existing") = False
is a function You need to write to update the excel file.
I wrote a quick one in one of my first post in this thread.
If you don't have it in your code it will stop the execution on that line.
varInsPnt(0)=x
varInsPnt(1)=y
varInsPnt(2)=z

strHandle=The unique identifier in the drawing for that object

Also remember you might want to wait till the save command finishes to run the code once
After save you have the new file name with path.
You can select all inserts in the drawing
Loop through the blocks
save a new excel workbook with all the block information.
done

VELI555:
I think I still have something wrong here. When I move a block in drawing. I still get the type mismatch failure. I have that function you mentioned in the code. But somehow when I get the failure and go to VBA window to see the code and move the mouse over the varInsPnt variable it will show me the strHandle="19F" value, but when I open the locals Window I see the X.Y and Z coordinates. I attached a picture so you can see what I mean. Are the tree values (x,y,z coordinates) under the one variable (varInsPnt) somehow, or is there something missing, and if they are why does the strHandle="19F" value shown when I move the mouse over the varInsPnt variable?

ChuckHardin:
Hope my translations are right.


--- Code: ---Option Explicit
Private ExcelApp As Excel.Application

Private Sub AcadDocument_EndSave(ByVal FileName As String)
 Debug.Print FileName
 Stop 'Put this in here so you can see how the code works
 'Just press [F8] to step to the next line
 DoExcelUpdate Replace(FileName, ".dwg", ".xlsx")
End Sub

Private Sub DoExcelUpdate(sFileName As String)
Dim objWorkBook As Workbook
Dim objSheet As Worksheet
Dim objUsedRange As Range
Dim lngRow As Long
Dim objSelSet As AcadSelectionSet
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim objEnty As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim varInsPnt As Variant
Dim strHandle As String
Dim lngCnt As Long

On Error GoTo Err_Control

 'Open Excel
 If ConnectToExcel = False Then
      MsgBox "Ei voitu yhdistää Excel!" & vbCrLf & "Poistuminen nyt!"
 End If
 If FileExist(sFileName) = True Then
      'Set objSheet
      Set objWorkBook = ExcelApp.Workbooks.Open(sFileName)
      Set objSheet = objWorkBook.Worksheets(1)
      Set objUsedRange = objSheet.UsedRange
      'Clear Excel Spread Sheet
      objUsedRange.ClearContents
 Else
      'Create Sheet and return objSheet
      Set objWorkBook = ExcelApp.Workbooks.Add
      objWorkBook.SaveAs sFileName
      Set objSheet = objWorkBook.Worksheets(1)
 End If
 'Set Column Headers
 'Not sure of the Translation
 objSheet.Cells(1, 1) = "blokkia nimi" 'lohkonimi Block Name
 objSheet.Cells(1, 2) = "kahva" 'Handle
 objSheet.Cells(1, 3) = "X"
 objSheet.Cells(1, 4) = "Y"
 objSheet.Cells(1, 5) = "Z"
 lngRow = 2 'This is the next row after the header row
 'Set the selection set
 Set objSelSet = ThisDrawing.PickfirstSelectionSet
 'Create a filter that gets only Block References
 intType(0) = 0: varData(0) = "INSERT"
 'Fill the Selection Set
 objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
 'Now step through the Selection Set for each Entity and apply the following code:
 For Each objEnty In objSelSet 'Kinda like this
      'Set objEnty = objSelSet.items(lngCnt)
      If TypeOf objEnty Is AcadBlockReference Then 'It is a Block Ref
           Set objBlkRef = objEnty 'Set it so the drop down works after typing a "."
           varInsPnt = objBlkRef.InsertionPoint 'Get the insertion point
           strHandle = objBlkRef.Handle 'Get the Handle
           'If you want Attribute values you will need to do a Function that returns the Att Values
           Debug.Print objBlkRef.Name & " Handle: " & strHandle & " Insertion Point: " & CStr(varInsPnt(0)) & ", " & CStr(varInsPnt(1)) & ", " & CStr(varInsPnt(2))
           'Put in excel here
           objSheet.Cells(lngRow, 1) = objBlkRef.Name
           objSheet.Cells(lngRow, 2) = strHandle
           objSheet.Cells(lngRow, 3) = CStr(varInsPnt(0))
           objSheet.Cells(lngRow, 4) = CStr(varInsPnt(1))
           objSheet.Cells(lngRow, 5) = CStr(varInsPnt(2))
           'Row adder
           lngRow = lngRow + 1
      End If
 Next 'Next entity in selection set
 'Save sheet
 objWorkBook.Save
 objWorkBook.Close
 Set ExcelApp = Nothing
 
Exit_Here:
 Exit Sub
Err_Control:
 Select Case Err.Number
      Case Else
           Debug.Print Err.Number & ": " & Err.Description
           Resume Exit_Here
 End Select
End Sub

Public Function FileExist(strFile As String) As Boolean
'ei tiedosto olemassa?
 If Dir(strFile, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) = "" Then
      FileExist = False
 Else
      FileExist = True
 End If

End Function


--- End code ---

VELI555:
Hi Everybody

Some time has pass since my last visit here. I have been busy doing my work. Chuck Hardin has helped me a lot to get the link between Excel and AutoCad work in both ways. I want to thank him for that. But now he has been busy so I would like to ask help from the other members here. We managed to get the link work (thanks to Chuck) both ways. But now we would also like to get the rotation value of a block to excel and when changin the value in Excel it would rotate the block in AutoCad? Do anyone know how it would be done?

Best regards
Veli

Navigation

[0] Message Index

[*] Previous page