Hi,
I'm trying to automate something that takes a lot of time at my company.
We got a lot of P&ID drawings full of tags. I want to automate the modification of tags according to an excel table.
I got something working but it's not reliable. It often doesn't work and it's very slow.
Please comment on it. I'm no programmer besides some programming classes back in school.
The form I call from.
It's function is to let the user pick which P&ID's should be put in the modification loop.
It's just a listbox (filenames), a textbox (for the file location) and a button.
Private Sub CommandButton1_Click()
Dim vtPid As Variant
ReDim vtPid(0)
Dim i As Integer, j As Integer
j = 0
For i = 0 To lstPid.ListCount - 1
If lstPid.Selected(i) = True Then
ReDim Preserve vtPid(j)
vtPid(j) = lstPid.List(i)
j = j + 1
End If
Next
frmPidTag.Hide
Call Modifie_PIDTag(vtPid, txtLocation.Text)
End Sub
The code is in my module.
First I open the excel (table with 2 columns, old and new tag) and put the table in an array.
The array is then used cycle through al entities.
[b] I'm trying to change certain text located in the layer "instrumentation".[/b] It's just text strings, no blocks or anything.
I'd like to use another method to get only the entities with possible matches but this seems to be the only reliable method. Only cycling textstrings would be better.
Sub Modifie_PIDTag(ByVal vtPid As Variant, ByVal varLocation As String)
' Create the Excel object
Dim oExcel As Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim aryPID()
Dim LastRow As Integer
Dim LastColumn As Integer
' Open existing workbook
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Open(varLocation & "EXCEL\DrawingData.xlsx")
'Set oExcel = New Excel.Application
oExcel.Visible = False
' Open worksheet
Set oSheet = oBook.Worksheets("PIDtag")
oSheet.Activate
' Read Excel
LastColumn = oSheet.Cells(1, oSheet.Columns.count).End(xlToLeft).Column
LastRow = oSheet.Cells(oSheet.Rows.count, 1).End(xlUp).Row
ReDim aryPID(1 To LastRow, 1 To LastColumn)
aryPID = oSheet.Range(oSheet.Cells(1, 1), oSheet.Cells(LastRow, LastColumn))
' Cleanup
oBook.Close
oExcel.Quit
Set oSheet = Nothing
Set oBook = Nothing
Set oExcel = Nothing
' Create the Autocad object
On Error Resume Next
Set objAcadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
MsgBox ("AutoCAD is not running...")
End
Else
Set objAcadDoc = objAcadApp.ActiveDocument
Set objMspace = objAcadDoc.ModelSpace
End If
Dim Entity As AcadEntity
Dim Doc As AcadDocument
Dim i As Integer, j As Integer
Dim saveloc As String
For j = 0 To UBound(vtPid)
'MsgBox vtPid(j)
On Error Resume Next
Set Doc = Documents.Open(varLocation & "TEMPLATE\" & vtPid(j) & ".dwg", False)
If Err Then
MsgBox "error"
Err.Clear
End
Else
AppActivate objAcadApp.Caption
i = 0
For Each Entity In Doc.ModelSpace
If (Entity.Layer = "INSTRUMENTATION") And (Entity.EntityName = "AcDbAttributeDefinition") Then
For i = LBound(aryPID) + 1 To UBound(aryPID)
If Entity.TagString = CStr(aryPID(i, 1)) Then
Entity.TagString = CStr(aryPID(i, 2))
End If
Next
End If
Next
saveloc = varLocation & "\DWG\" & vtPid(j) & "-new.dwg"
ThisDrawing.SaveAs saveloc
ThisDrawing.Close
End If
Next
End Sub
The get/create autocad object may seem out of place there but it was the only way to solve an error.
Calling the subroutine from a form gave me automation errors. I think it was a focus/activation problem. Anyway, this seems to solve it.
Thanks!
