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