Can anyone provide a VBA code example to read dwg file title block

Posted on 2006-05-11
Last Modified: 2009-07-29

We have a dwg files with title block which contains name of the customer, components etc. I want to read those information and display on the screen.
Question by:sandip_patankar
    LVL 13

    Expert Comment

    If you have the title block with attributes you can extract the information to Excel.
    Extracting a database from attributes
    After you insert all your blocks and attributes, you can extract the data using the
    Attribute Extraction Wizard. To start the wizard, choose
    Tools➪Attribute Extraction.
    ✦ The horizontal view is like a spreadsheet, with a column for each tag and a
    row for each incident of the block.
    ✦ The vertical view lists the attribute values vertically so that each value gets
    its own row.
    Choose No Template
    Click Alternate view to see each view.
    n the Select Attributes screen, shown in Figure 18-28, you choose the blocks you
    want to work with and their attributes.
    In the Export screen, you name the file that will contain the extracted attributes.
    Click the Ellipsis button to specify the location and file name in a typical file
    dialog box.

    ✦ Microsoft Excel (*.xls): Creates an Excel spreadsheet.
    To create the file, click Finish. A dialog box asks if you want to write to the file. Click
    Yes. The wizard closes.

    I can supply the complete text if needed.



    Author Comment


    I need VB code to read the title block.  
    LVL 13

    Expert Comment

    What I did was to make a block and enter attribute data. I then had the information saved into an excel file, complete with column titles that reflected the attribute descriptions.  The text is in "2004 Bible" e-book.
    LVL 13

    Accepted Solution

    For 125 points you get the function I used to replace text in autocad modify it to suit your needs

    Function acadREPLACETEXT() As String
    Dim myBLOCK As AcadBlock
    Dim ThisBlock As AcadBlockReference
    Dim atts As Variant
    Dim NewString As String
    Dim ThisAtt As AcadAttributeReference
    Dim Loc As Long
    Dim thisText As AcadText
    Dim txtLength As Long
    Dim Find500 As Boolean
    Dim FindHRSHT As Boolean
    Dim FindSHT As Boolean

    Find500 = False
    FindHRSHT = False
    FindSHT = False

    Dim MSIcount As Long
    Dim Ent As AcadEntity

    MSIcount = 1

    For MSIcount = 1 To (ACADapp.ActiveDocument.ModelSpace.Count - 1)
        If ACADapp.ActiveDocument.ModelSpace.Item(MSIcount).ObjectName = "AcDbBlockReference" Then
            Set ThisBlock = ACADapp.ActiveDocument.ModelSpace.Item(MSIcount)
            atts = ThisBlock.GetAttributes
            Count = 0
            For Count = 0 To UBound(atts)
                Set ThisAtt = atts(Count)
                Loc = 0
                Loc = VBA.InStr(1, ThisAtt.TextString, "500", vbTextCompare)
                txtLength = 0
                txtLength = Len(ThisAtt.TextString)
                If Loc = 1 And txtLength = 6 Then
                    ThisAtt.TextString = "500610"
                    Find500 = True
                End If
                Loc = VBA.InStr(1, ThisAtt.TextString, "HRSHT", vbTextCompare)
                If Not Loc = 0 Then
                    ThisAtt.TextString = "HRSHT(72X120)"
                    FindHRSHT = True
                End If
                Loc = VBA.InStr(1, ThisAtt.TextString, " SHT", vbTextCompare)
                If Not Loc = 0 Then
                    ThisAtt.TextString = StkQty & " SHT"
                    FindSHT = True
                End If
        End If
        If ACADapp.ActiveDocument.ModelSpace.Item(MSIcount).ObjectName = "AcDbText" Then
            Set thisText = ACADapp.ActiveDocument.ModelSpace.Item(MSIcount)
            Loc = VBA.InStr(1, thisText.TextString, "LAST PLOT", vbTextCompare)
            If Not Loc = 0 Then
                thisText.TextString = "LAST PLOT DATE: " & Date & " " & Time
            End If
        End If
    acadREPLACETEXT = "Didn't find: "
    If Find500 = False Then
        acadREPLACETEXT = acadREPLACETEXT & "500, "
    End If
    If FindHRSHT = False Then
    End If
    If FindSHT = False Then
    End If
    If acadREPLACETEXT = "Didn't find: " Then
        acadREPLACETEXT = "Replaced all strings"
    End If
    End Function
    LVL 10

    Expert Comment

    did you ever come up wit a solution?
    LVL 10

    Expert Comment

    IMO, Corey should get this one, that should have gotten them started.
    LVL 13

    Expert Comment

    Thank you Norrin

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    Top 6 Sources for Identifying Threat Actor TTPs

    Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

    Suggested Solutions

    Our company has proprietary drawing files that we do not give to our customers for final documentation. Our customers now require that we give them these drawings. They understand that they are proprietary and do not require them to be in AutoCAD bu…
    If, like me, you find yourself repeatedly and tediously joining many segments (lines, arcs) in other people's drawings back into polylines that can be used more effectively in Computer Aided Machining and Laser Cutting, then this article is for you!…
    Migrating to Microsoft Office 365 is becoming increasingly popular for organizations both large and small. If you have made the leap to Microsoft’s cloud platform, you know that you will need to create a corporate email signature for your Office 365…
    Sending a Secure fax is easy with eFax Corporate ( First, Just open a new email message.  In the To field, type your recipient's fax number You can even send a secure international fax — just include t…

    759 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    10 Experts available now in Live!

    Get 1:1 Help Now