Importing Title Block Info from Excel

[Ed Jobe]

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

[stusic]

Hrm, I get an error: "6, Overflow"

Seems like a simple problem. Do you think it has anything to do with the fact that there's about a thousand more entries in my excel file than the example I sent you?

EDIT: It seems that this error is caused by numbers being too big for a variable. I wonder if this could be the issue.

[Ed Jobe]

You're on the right track. The only place I thought that might be a problem is in the line that gets the ProjNo from the dwg title. I cast the 7 digits as Long. That should be good for numbers up to 2,147,483,647. Now I see that I missed the iterator in the For..Next loop. Change i from Integer to Long.

When dealing with errors, its critical that you know where they are coming from. Then you can start to figure out why. That's why if its getting caught by my error trapping, the dialog tells you what procedure the error is from. To find the exact spot, go to your vba ide Tools>Options, General tab and check Break on All Errors. Then step through till you get the error.

[stusic]

I hate to keep pestering you, but any ideas?

The named selection set exists

In:

Set AddSelectionSet = ThisDrawing.SelectionSets.Add(SetName)

I got an error before too, but it's different now...

[Ed Jobe]

If you still have Break on All Errors turned on, yes you will get an error. Turn it off after you're done testing. BTW, I uploaded a fixed dvb.

[stusic]

Ed, thanks a heap, this works great!

I've sure learned a lot about VBA. Maybe I should thank my management also for mishandling implementation of new hardware

[Ed Jobe]

Glad it worked for you. Its stuff like that that's the reason I got started programming.

[stusic]

Haha, I hear ya brother.

One (slightly related) question: I seem to be missing soem references (are you using acad 2012 and/or Excel 2010?). Is there a quick fix to make it work with 2011/Excel 2007?

Thanks again

[Ed Jobe]

I used Map 2010 and xl 2010. Just go to Tools>References and uncheck the ones that start with "MISSING:" and then find the appropriate library.