AfraLisp Blog

The AutoLisp/Visual Lisp/VBA Resource Website

AfraLisp Blog

Home Newsletter Utter Rubbish Coding Tips AutoCAD Tips Contact Downloads WAUN

VBA and DataBases (67kb)

Title Block Tutorial

This is a sample VBA routine written for AutoCAD Rel 14, 2000, 2000i and 2002.
This application will demonstrate how to import and export Title Block attribute data, to and from an Access 2000 database.

Usage AutoCAD 14 and 2000.

Unzip the files Tblock2000.dvb, Tblock2000.Lsp, Tblock.Dwg and Tblock.Mdb to your working directory.
Insert the Tblock.Dwg. as a block into any drawing.

Usage AutoCAD 2000i and 2002.

Unzip the files Tblock2002.dvb, Tblock2002.Lsp, Tblock.Dwg and Tblock.Mdb to your working directory.
Insert the Tblock.Dwg. as a block into any drawing.

It should look like this :

Title Block

Type (load "tblock2000(2)") at the command prompt.
Type "tblock2000(2)" to run the application.

(If you have problems when writing or running this projects, ensure that the Microsoft DAO 3.6 Object Library is selected in your VBA References.)

The Source Code. 

Public acad As Object
Public doc As Object
Public ms As Object
Public ss As Object
Public ssnew As Object
Public Theatts As Variant
Public MsgBoxResp As Integer
Public dbInfo As Database
Public rsInfo As Recordset
'declare global variables

Private Sub CommandButton1_Click()

    UpdateAttrib 0, UserForm1.TextBox1.Text
    UpdateAttrib 1, UserForm1.TextBox2.Text
    UpdateAttrib 2, UserForm1.TextBox3.Text
    UpdateAttrib 3, UserForm1.TextBox4.Text
    UpdateAttrib 4, UserForm1.TextBox5.Text
    'get the attribute values
    
    ssnew.Item(0).Update
    'update the attribute block
    
    End
End Sub

Sub UpdateAttrib(TagNumber As Integer, BTextString As String)
  'This Sub Procedure tests the attribute data to check
  'that is not a null value
  
  If BTextString = "" Then
  'if the attribute is empty
  
    Theatts(TagNumber).TextString = "-"
    'put a '-' place holder
    
   Else
   'if it is not empty
   
    Theatts(TagNumber).TextString = BTextString
    'use the attribute value
ThisDrawing.SelectionSets.Item("TBLK").Delete
'delete the block
    
  End If
  
End Sub

Private Sub CommandButton2_Click()
ThisDrawing.SelectionSets.Item("TBLK").Delete
End

End Sub


Private Sub CommandButton3_Click()

Dim DrgNumber As String
Dim Msg As String
Dim Msg1 As String
Dim Style As String
Dim TitleLine As String
Dim Response As String
'declare local variables


DrgNumber = UserForm1.TextBox2.Text
'get the drawing number

Set dbInfo = OpenDatabase("TBLOCK.MDB")
'set the reference to the database

'if the database is not an Access dadtabase use the following line
'Set dbInfo = OpenDatabase("
'C:\DATABASE PATH\", False, False, "dBASE III;C:\DATABASE PATH\TBLOCK.DBF;")

Set rsInfo = dbInfo.OpenRecordset("SELECT * 
FROM TITLEBLOCK WHERE DRGNO = '" & DrgNumber & "'", dbOpenDynaset)
'search for the drawing number

UserForm1.Hide
'hide the dialogue box

If (rsInfo.RecordCount <> 0) Then
'if the drawing number is found

    Msg = "Drawing already Exists in the DataBase."
    Msg1 = "Would you like to Update the Drawing Details?"
    Style = vbYesNo + vbQuestion + vbDefaultButton2
    Title = "Existing Entry in DataBase"
    'set variables for message box
    

    Response = MsgBox(Msg & Chr(13) & Chr(10) & Msg1, Style, Title)
    'display the message box
    
        If Response = vbYes Then
        'if the user wants to update the database
        
            UserForm1.rsInfo.Edit
            'open the database for edit
'-------------------
 'this section is for AutoCAD 14/2000           
            UserForm1.rsInfo("TITLE") = UserForm1.TextBox1.Text
            UserForm1.rsInfo("DRGNO") = UserForm1.TextBox2.Text
            UserForm1.rsInfo("DATE") = UserForm1.TextBox3.Text
            UserForm1.rsInfo("DRAWN") = UserForm1.TextBox4.Text
            UserForm1.rsInfo("SCALE") = UserForm1.TextBox5.Text
            'get the field values
'--------------------
'For AutoCAD 2000i/2002 replace the preceding section with this :
            'UserForm1.rsInfo.Fields("TITLE") = UserForm1.TextBox1.Text
            'UserForm1.rsInfo.Fields("DRGNO") = UserForm1.TextBox2.Text
            'UserForm1.rsInfo.Fields("DATE") = UserForm1.TextBox3.Text
            'UserForm1.rsInfo.Fields("DRAWN") = UserForm1.TextBox4.Text
            'UserForm1.rsInfo.Fields("SCALE") = UserForm1.TextBox5.Text
            'get the field values
'---------------------
                        
            UserForm1.rsInfo.Update
            'update the database
            
            MsgBox ("DataBase has been Updated"), , "Update DataBase"
            'inform the user
            
            UserForm1.Show
            'reinstate the dialogue box
            
         Else
         'if the user does not want to update
         
        UserForm1.Show
        'reinstate the dialogue
        
        End If
  Else
  'if the drawing number has not been found
    
    Msg = "Drawing has not been Entered Into DataBase."
    Msg1 = "Would you like to Enter the Drawing Details?"
    Style = vbYesNo + vbQuestion + vbDefaultButton2
    Title = "New Entry in DataBase"
    'set up the message box variables
    
     Response = MsgBox(Msg & Chr(13) & Chr(10) & Msg1, Style, Title)
     'display the message box
        If Response = vbYes Then
        'if the user wants to enter the drawing details
        
            UserForm1.rsInfo.AddNew
            'open the dtabase to add a new record
            
'-------------------
 'this section is for AutoCAD 14/2000           
            UserForm1.rsInfo("TITLE") = UserForm1.TextBox1.Text
            UserForm1.rsInfo("DRGNO") = UserForm1.TextBox2.Text
            UserForm1.rsInfo("DATE") = UserForm1.TextBox3.Text
            UserForm1.rsInfo("DRAWN") = UserForm1.TextBox4.Text
            UserForm1.rsInfo("SCALE") = UserForm1.TextBox5.Text
            'get the field values
'--------------------
'For AutoCAD 2000i/2002 replace the preceding section with this :
            'UserForm1.rsInfo.Fields("TITLE") = UserForm1.TextBox1.Text
            'UserForm1.rsInfo.Fields("DRGNO") = UserForm1.TextBox2.Text
            'UserForm1.rsInfo.Fields("DATE") = UserForm1.TextBox3.Text
            'UserForm1.rsInfo.Fields("DRAWN") = UserForm1.TextBox4.Text
            'UserForm1.rsInfo.Fields("SCALE") = UserForm1.TextBox5.Text
            'get the field values
'---------------------
            
            UserForm1.rsInfo.Update
            'update the database
            
            MsgBox ("Drawing has been Entered into DataBase"), , 
            "Enter Into DataBase"
            'inform the user
            
            UserForm1.Show
            'reinstate the dialogue box
            
        Else
        'if the user does not want to enter the drawing details
        
            UserForm1.Show
            'reinstate the dialoge box
            
        End If
End If
End Sub

Private Sub UserForm_Initialize()

  Dim BlkG(0) As Integer
  Dim TheBlock(0) As Variant
  Dim Pt1(0 To 2) As Double
  Dim Pt2(0 To 2) As Double
  'declare local variables
  

  Set acad = GetObject(, "AutoCAD.Application")
  'set reference to AutoCAD
  
  Set doc = acad.ActiveDocument
  'set reference to the drawing
  
  Set ms = doc.ModelSpace
  'set reference to model space
  
  Set ssnew = doc.SelectionSets.Add("TBLK")
  'create a selection set
  
  Pt1(0) = 0: Pt1(1) = 0: Pt1(2) = 0
  Pt2(0) = 3: Pt2(1) = 3: Pt2(2) = 0
  'set up the array
  
  BlkG(0) = 2
  'group code 2 for block name
  
  TheBlock(0) = "TBLOCK"
  'the name of the attribute block
  
  ssnew.Select 5, Pt1, Pt2, BlkG, TheBlock
  'get the block
  
  If ssnew.Count >= 1 Then
  'if the block is found
  
    Theatts = ssnew.Item(0).GetAttributes
    'get the attributes
    
    UserForm1.TextBox1.Text = UCase(LTrim(Theatts(0).TextString))
    'get the title attribute
    'clear any leading spaces and
    'convert to uppercase
    
    
    UserForm1.TextBox2.Text = UCase(LTrim(Theatts(1).TextString))
    'get the drawing number attribute
    'clear any leading spaces and
    'convert to uppercase
    
    UserForm1.TextBox3.Text = Date
    'get todays date
    
    UserForm1.TextBox4.Text = UCase(LTrim(Theatts(3).TextString))
    'get the draughtsmans name
    'clear any leading spaces and
    'convert to uppercase
    
    UserForm1.TextBox5.Text = "1:" & CStr(doc.GetVariable("DIMSCALE"))
    'get the drawing scale, convert it to a string
    'and prefix it with 1:
    
    
    UserForm1.TextBox1.SetFocus
    UserForm1.TextBox1.SelStart = 0
    UserForm1.TextBox1.SelLength = Len(UserForm1.TextBox1.Text)
    'set the focus to the drawing title and highlight it
    
  Else
  'if no attribute title block is found
  
   MsgBox "Sorry - No Title Block Attributes....", vbCritical, 
   "AfraLisp Tutorial"
   'inform the user that there is no attribute title block
   
   End
   'end the program
   
 End If
 
End Sub


Create a new module and add this :

Sub TBlock()

UserForm1.Show

End Sub
 
 
The AutoLisp/Visual Lisp/VBA Resource Website

Copyright 1999-Perpetuity by AfraLisp

All rights reserved.
Information in this document is subject to change without notice.
Site created and maintained by Kenny Ramage

The AutoLisp/Visual Lisp/VBA Resource Website