VBA MsgBox in program to export title attributes from AutoCAD to MS Access

[Brian C]

I am new at VBA for AutoCAD and have wrote this program to export title block attributes to a MS Access database. The program works fine in exporting, but I cannot get the message box to fill in the data. The box comes up, but the title information is blank.

What am I doing wrong?

Here is the code:

Sub ExportTitle()

' Open database and delete old records if exist
' ---------------------------------------------
    Dim db As database
    Dim dbname As String

    dbname = "Project_Drawings.mdb"
    Set db = OpenDatabase(dbname)

' Get Drawing number and path
' ---------------------------
    Dim activeDoc As AcadDocument
    Dim Shortlength As Integer
    Dim DwgName As String
    Dim DocName As String
    Set activeDoc = ThisDrawing.Application.ActiveDocument
    DocName = activeDoc.Name
    DocLength = Len(DocName)
    
' Strip of extension .dwg
' -------------------------------
    Shortlength = DocLength - 4
    DwgPath = activeDoc.Path
    DwgName = Left(DocName, Shortlength)
    
' Open recordset in table
' -----------------------
    Dim data As Recordset
    Dim DwgTable As String

' Determine Drawing Tables
' --------------------------
    
    DwgTable = "P1302_111"
   

    Set data = db.OpenRecordset(DwgTable, dbOpenDynaset)

' Clear old values from table
' ---------------------------
'Dwg is name of table heading

    db.Execute "DELETE FROM " & DwgTable & " WHERE Dwg = '" & DwgName & "'"
    Dim attribs
    Dim Title1 As String
    Dim Title2 As String
    Dim Wcode As String
    Dim DwnBy As String
    Dim DwnDate As String
    Dim RevNo As String
    Dim ShtNo As String

' Make Selection set of Blocks
' ----------------------------
    Dim ssnew As Object
    Set ssnew = ThisDrawing.SelectionSets.Add("VBA")
    Dim Pt1(0 To 2) As Double
    Dim Pt2(0 To 2) As Double
    Dim GC(0 To 1) As Integer
    Dim GV(0 To 1) As Variant
    Pt1(0) = 0#
    Pt1(1) = 0#
    Pt1(2) = 0#
    Pt2(0) = 0#
    Pt2(1) = 0#
    Pt2(2) = 0#
    GC(0) = 0
    GV(0) = "INSERT"
    GC(1) = 2
' the border block name
    GV(1) = "WM_?-SIZE" 
    ssnew.Select acSelectionSetAll, Pt1, Pt2, GC, GV
       
' Get Attribute values
' ---------------------
    For Each entity In ssnew
        attribs = entity.GetAttributes
        For I = LBound(attribs) To UBound(attribs)
            If attribs(I).TagString = "TITLE1" Then
              Title1 = attribs(I).TextString
            End If
            If attribs(I).TagString = "TITLE2" Then
              Title2 = attribs(I).TextString
            End If
            If attribs(I).TagString = "WCODE" Then
              Wcode = attribs(I).TextString
            End If
            If attribs(I).TagString = "DWG_BY" Then
              DwnBy = attribs(I).TextString
            End If
            If attribs(I).TagString = "SHEET#" Then
              ShtNo = attribs(I).TextString
            End If
            If attribs(I).TagString = "DWG_DATE" Then
              DwnDate = attribs(I).TextString
            End If
            If attribs(I).TagString = "REV#" Then
              RevNo = attribs(I).TextString
            End If
         Next
         
         'ShtNo = Right(ShtNo, 1)
       
' Fill Database Table
' -----------------
         
         'If DwgNo = "" Then DwgNo = " "
         If ShtNo = "" Then ShtNo = " "
         If Title1 = "" Then Title1 = " "
         If Title2 = "" Then Title2 = " "
         If Wcode = "" Then Wcode = " "
         If RevNo = "" Then RevNo = " "
         If DwnBy = "" Then DwnBy = " "
         If DwnDate = "" Then DwnDate = " "
         
	'Call ExportMsg1

                 
         data.AddNew
                    
         data!Dwg = DwgName
         data!Title1 = Title1
         data!Title2 = Title2
         data!Sheets = ShtNo
         data!Wcode = Wcode
         data!Drawn = DwnBy
         data!Date = DwnDate
         data!Rev = RevNo
  
         data.Update
   
    
    Next
    
' Close Database
' --------------
  data.Close
  db.Close
  Set data = Nothing
  Set db = Nothing
  ssnew.Delete
  
End Sub

Private Sub ExportMsg1()

  MsgBox _
"The following is being added to the database:" & vbCrLf & _
"------------------------------------------------" & vbCrLf & _
"Drawing:   " & DwgName & vbCrLf & _
"Sheet:    " & ShtNo & vbCrLf & _
"------------------------------------------------" & vbCrLf & _
"Work Code:    " & Wcode & vbCrLf & _
"Title 1:   " & Title1 & vbCrLf & _
"Title 2:   " & Title2 & vbCrLf & _
"Rev No.:   " & RevNo & vbCrLf & _
"Drawn By:  " & DwnBy & vbCrLf & _
"Drawn Date:    " & DwnDate

End Sub

Thanks!

[arshiel88]

Have you tried checking the variables (debug.print) before displaying the message box?

[fixo]

Hi Brian C,
the possible problem is may be on the Database object
has the same name both in Access and AutoCAD
This slightly edited code working good on my settings:
A2010 / Access 2015 (Database was saved as .mdb in 2003 format)
Pay attention on how to avoid the duplicate selection set creating

Option Explicit

Sub ExportTitle()

' Open database and delete old records if exist
' ---------------------------------------------
    Dim db As DAO.Database
    Dim dbname As String

    dbname = "Project_Drawings.mdb"
    Set db = OpenDatabase(dbname)

' Get Drawing number and path
' ---------------------------
    Dim activeDoc As AcadDocument
       Dim DocLength As Integer
    Dim Shortlength As Integer
    Dim DwgPath As String
    Dim DwgName As String
    Dim DocName As String
    Set activeDoc = ThisDrawing.Application.ActiveDocument
    DocName = activeDoc.Name
    DocLength = Len(DocName)
    
' Strip of extension .dwg
' -------------------------------
    Shortlength = DocLength - 4
    DwgPath = activeDoc.Path
    DwgName = Left(DocName, Shortlength)
    
' Open recordset in table
' -----------------------
    Dim data As Recordset
    Dim DwgTable As String

' Determine Drawing Tables
' --------------------------
    
    DwgTable = "P1302_111"
   

    Set data = db.OpenRecordset(DwgTable, dbOpenDynaset)

' Clear old values from table
' ---------------------------
'Dwg is name of table heading

    db.Execute "DELETE FROM " & DwgTable & " WHERE Dwg = '" & DwgName & "'"
    Dim attribs
    Dim Title1 As String
    Dim Title2 As String
    Dim Wcode As String
    Dim DwnBy As String
    Dim DwnDate As String
    Dim RevNo As String
    Dim ShtNo As String

' Make Selection set of Blocks
' ----------------------------
    Dim ssnew As Object
    Dim setObj As Object
   ' dim setColl as ThisDrawing.se
    Dim Entity As AcadEntity
         With activeDoc
         ' Set setColl = .SelectionSets
          For Each setObj In .SelectionSets
               If setObj.Name = "VBA" Then
                    .SelectionSets.Item("VBA").Delete
                    Exit For
               End If
          Next

    Set ssnew = activeDoc.SelectionSets.Add("VBA")
    End With
    Dim Pt1(0 To 2) As Double
    Dim Pt2(0 To 2) As Double
    Dim GC(0 To 1) As Integer
    Dim GV(0 To 1) As Variant
    Pt1(0) = 0#
    Pt1(1) = 0#
    Pt1(2) = 0#
    Pt2(0) = 0#
    Pt2(1) = 0#
    Pt2(2) = 0#
    GC(0) = 0
    GV(0) = "INSERT"
    GC(1) = 2
' the border block name
    GV(1) = "WM_?-SIZE"
    ssnew.Select acSelectionSetAll, Pt1, Pt2, GC, GV
       
' Get Attribute values
' ---------------------
Dim i
    For Each Entity In ssnew
        attribs = Entity.GetAttributes
        For i = LBound(attribs) To UBound(attribs)
            If attribs(i).TagString = "TITLE1" Then
              Title1 = attribs(i).TextString
            End If
            If attribs(i).TagString = "TITLE2" Then
              Title2 = attribs(i).TextString
            End If
            If attribs(i).TagString = "WCODE" Then
              Wcode = attribs(i).TextString
            End If
            If attribs(i).TagString = "DWG_BY" Then
              DwnBy = attribs(i).TextString
            End If
            If attribs(i).TagString = "SHEET#" Then
              ShtNo = attribs(i).TextString
            End If
            If attribs(i).TagString = "DWG_DATE" Then
              DwnDate = attribs(i).TextString
            End If
            If attribs(i).TagString = "REV#" Then
              RevNo = attribs(i).TextString
            End If
         Next
         
         'ShtNo = Right(ShtNo, 1)
       
' Fill Database Table
' -----------------
         
         'If DwgNo = "" Then DwgNo = " "
         If ShtNo = "" Then ShtNo = " "
         If Title1 = "" Then Title1 = " "
         If Title2 = "" Then Title2 = " "
         If Wcode = "" Then Wcode = " "
         If RevNo = "" Then RevNo = " "
         If DwnBy = "" Then DwnBy = " "
         If DwnDate = "" Then DwnDate = " "
         
    'Call ExportMsg1

                 
         data.AddNew
                    
         data!Dwg = DwgName
         data!Title1 = Title1
         data!Title2 = Title2
         data!Sheets = ShtNo
         data!Wcode = Wcode
         data!Drawn = DwnBy
         data!Date = DwnDate
         data!Rev = RevNo
  
         data.Update
   
    
    Next
    
' Close Database
' --------------
  data.Close
  db.Close
  Set data = Nothing
  Set db = Nothing
  ssnew.Delete
  
End Sub

Private Sub ExportMsg1()

  MsgBox _
"The following is being added to the database:" & vbCrLf & _
"------------------------------------------------" & vbCrLf & _
"Drawing:   " & DwgName & vbCrLf & _
"Sheet:    " & ShtNo & vbCrLf & _
"------------------------------------------------" & vbCrLf & _
"Work Code:    " & Wcode & vbCrLf & _
"Title 1:   " & Title1 & vbCrLf & _
"Title 2:   " & Title2 & vbCrLf & _
"Rev No.:   " & RevNo & vbCrLf & _
"Drawn By:  " & DwnBy & vbCrLf & _
"Drawn Date:    " & DwnDate

End Sub

[Brian C]

Fixo, thanks for your input. I did run what posted, but I still did not get the message box to fill in. After a bit of research, I read that I had to make my declarations "public" because of the EportMessage1 being a Private Sub.

So I added the following at the top:

Public DwgName As String
'Public ssnew As Object
Public Title1 As String
Public Title2 As String
Public Wcode As String
Public DwnBy As String
Public DwnDate As String
Public RevNo As String
Public ShtNo As String

Everything worked fine. What really helped was your selection set deletion on error, I added that to my code.

[Brian C]

And arshiel88, thank you to introducing me to the debug.print function!

[fixo]

Glad you sorted it out
Have a nice all
Cheers

[Brian C]

Actually I am quite happy with how this VBA program is working

I plan on expanding it to include a form that will allow the user to select a project number from a list box, and dump the data to the project table. I will post my results.

I have done quite a bit of Autolisp over the years, but no Visual Lisp. Can anyone tell me if this export program can be done in Visual lisp instead of VBA, and if so, which is the better method?

[Ed Jobe]

Vlisp can access the vba object model. However, it can be a little more difficult. You don't have the vbaide, so you don't get intellisense to help you with syntax. You have to use the vba help and translate it to lisp without being context sensitive. Its far easier to do dialog boxes or forms in vba than lisp.

[fixo]

Vlisp can access the vba object model. However, it can be a little more difficult. You don't have the vbaide, so you don't get intellisense to help you with syntax. You have to use the vba help and translate it to lisp without being context sensitive. Its far easier to do dialog boxes or forms in vba than lisp.

@ Ed Jobe
Have agreed completely
@Brian C
Anyway you can do it,
see simple lisp, hope you know how to use it,
see in attachment

AccessDemo.lsp

[Brian C]

fixo, I am getting an error: error: bad argument type: VLA-OBJECT nil

I suspect it is something to do with this line:

(vlax-get-or-create-object "DAO.DBEngine.36")

I am using Access XP (2002) and AutoCAD 2010 on Windows 7 with the latest updates.