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:
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!