Its been awhile since I contributed some code here, so I created a dvb. Its all tested with your docs. You just have to make sure that the titleblock is always inserted with the name "TitleBlock". Or, you could change the code to your needs. I'm also inserting the code here so the search engine can find it.
You just need to run the public sub UpdateTitleBlock() Your titleblock had more attributes than the xls you supplied. If there are more, just add them to the Select..Case statement in UpdateTitleBlock().
Option Explicit
' S:\Everyone\ENGR_REQUESTS\AutoREV\Data\GateWay1.xls
'Global vars
Private excelApp As Excel.Application 'points to excel application
Private wbkObj As Workbook 'points to excel workbook
Private rSearch As Range 'Range where the search is performed
Private rFound As Range 'Range where the data is found
Private dwginfo As Collection 'holds the "found" info
Public Function AddSelectionSet(SetName As String) As AcadSelectionSet
' This routine does the error trapping neccessary for when you want to create a
' selectin set. It takes the proposed name and either adds it to the selectionsets
' collection or sets it.
On Error Resume Next
Set AddSelectionSet = ThisDrawing.SelectionSets.Add(SetName)
If Err.Number <> 0 Then
Set AddSelectionSet = ThisDrawing.SelectionSets.Item(SetName)
AddSelectionSet.Clear
End If
End Function
Public Sub GetTitleBlockInfo(PrjNo As String)
On Error GoTo Err_Control
Set dwginfo = New Collection
With rSearch
Set rFound = .Find(What:=PrjNo, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rFound Is Nothing Then
dwginfo.Add rFound.Offset(, 1).Value, "SALES_ORDER"
dwginfo.Add rFound.Offset(, 3).Value, "CUSTOMER"
dwginfo.Add rFound.Offset(, 4).Value, "CITY"
dwginfo.Add rFound.Offset(, 5).Value, "STATE"
dwginfo.Add rFound.Offset(, 12).Value, "STORE_NAME"
Else
Err.Raise vbObjectError + 101
End If
End With
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case Is = 101
'Search Item not found.
'Pass them up to calling sub.
Err.Raise vbObjectError + 101, "Module1.GetTitleBlockInfo", "Search Item not found."
Resume Exit_Here
Case Else
'Handle unforseen errors.
'Pass them up to calling sub.
Err.Raise vbObjectError + 100, "Module1.GetTitleBlockInfo"
Resume Exit_Here
End Select
End Sub
Public Function GetExcel() As Excel.Application
On Error GoTo Err_Control
Dim m_app As Excel.Application
Set m_app = GetObject(, "Excel.Application")
Return_App:
Set GetExcel = m_app
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case Is = 429
'Excel is not running. Start it.
Set m_app = CreateObject("Excel.Application")
Resume Return_App
Case Else
'Handle unforseen errors.
MsgBox Err.Number & ", " & Err.Description, , "GetExcel"
Err.Clear
Resume Exit_Here
End Select
End Function
Public Function GetSS_BlockName(BlockName As String) As AcadSelectionSet
'creates a ss of blocks with the name supplied in the argument
Dim s2 As AcadSelectionSet
Set s2 = AddSelectionSet("ssBlocks") ' create ss with a name
s2.Clear ' clear the set
Dim intFtyp(3) As Integer ' setup for the filter
Dim varFval(3) As Variant
Dim varFilter1, varFilter2 As Variant
intFtyp(0) = -4: varFval(0) = "<AND"
intFtyp(1) = 0: varFval(1) = "INSERT" ' get only blocks
intFtyp(2) = 2: varFval(2) = BlockName ' whose name is specified in argument
intFtyp(3) = -4: varFval(3) = "AND>"
varFilter1 = intFtyp: varFilter2 = varFval
s2.Select acSelectionSetAll, , , varFilter1, varFilter2 ' do it
Set GetSS_BlockName = s2
End Function
Public Sub UpdateTitleblock()
Dim ent As Object
On Error GoTo Err_Control
'Open excel
Set excelApp = GetExcel()
Set wbkObj = excelApp.Workbooks.Open("S:\Everyone\ENGR_REQUESTS\AutoREV\Data\GateWay1.xls")
Set rSearch = wbkObj.Worksheets(1).Range("A:A")
GetTitleBlockInfo CLng(Left(ThisDrawing.Name, 7))
'Update DWG
Dim ss As AcadSelectionSet
Dim blk As AcadBlockReference
Set ss = GetSS_BlockName("TitleBlock")
Set blk = ss(0)
If blk.HasAttributes = True Then
Dim x As Long
Dim attArr As Variant
Dim att As AcadAttributeReference
attArr = blk.GetAttributes
For x = 0 To UBound(attArr)
Set att = attArr(x)
Select Case att.TagString
Case Is = "SALES_ORDER"
att.TextString = dwginfo("SALES_ORDER")
Case Is = "CUSTOMER"
att.TextString = dwginfo("CUSTOMER")
Case Is = "CITY"
att.TextString = dwginfo("CITY")
Case Is = "STATE"
att.TextString = dwginfo("STATE")
Case Is = "STORE_NAME"
att.TextString = dwginfo("STORE_NAME")
End Select
Next
End If
Cleanup:
'Cleanup out-of-process object, in reverse order of creation.
excelApp.Quit
Set rFound = Nothing
Set rSearch = Nothing
Set wbkObj = Nothing
Set excelApp = Nothing
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case Is = 1004
'File not found.
MsgBox "File not found." & vbCrLf & Err.Number & ", " & Err.Description, , Err.Source
Err.Clear
Resume Cleanup
Case Is = vbObjectError + 100
'Unhandled error in GetTitleBlockInfo
MsgBox "Unhandled Error in GetTitleBlockInfo(): " & Err.Number & ", " & Err.Description, , Err.Source
Err.Clear
Resume Cleanup
Case Is = vbObjectError + 101
'File not found.
MsgBox "Project Number was not found in Excel spreadsheet.", , Err.Source
Err.Clear
Resume Cleanup
Case Else
'Handle unforseen errors.
MsgBox Err.Number & ", " & Err.Description, , "UpdateTitleblock"
Err.Clear
Resume Cleanup
End Select
End Sub