Drawing Setup Project (119 Kb)

This is a Drawing Setup Routine written in VBA for AutoCAD R14.
The user is given a choice of 4 Drawing Sheets, 5 Drawing Sizes, and a Drawing Scale Factor. All sizes are Metric.

Usage.

Unzip the files to a temporary directory.
Copy all DWT (Drawing Template files) to the Template drawing sub-directory in you AutoCAD Rel 14 directory. (No files will be overwritten.)
Copy VbaSetup.dvb and VbaSetup.Lsp to any directory in your AutoCAD search path.
Type (load "vbasetup") at the command prompt.
Type "vbasetup" to run the application.

The Source Code. 

Private Sub cmdCancel_Click()
End
End Sub

Private Sub cmdOk_Click()

Dim acadApp As Object
Dim acadDoc As Object
Dim templateFileName As String
Dim DrgSheet As String
Dim DrgSize As String
Dim newLimits(0 To 3) As Double
Dim pViewport As Object
Dim sc As Double
Dim oldTextStyle As Object
Dim Blockref As Object
Dim InsertionPoint(0 To 2) As Double
Dim Mspace As Object
Dim Insertsheet As String
'declare variables


Me.Hide
'hide the dialogue box

Set acadApp = GetObject(, "AutoCAD.Application")
'setq reference to AutoCAD Application

    If Err Then
    'if there is another error

        MsgBox Err.Description
    'inform user

        Exit Sub
    'exit application

    End If

Set acadDoc = acadApp.ActiveDocument
'set reference to active document

If Not acadDoc.Saved Then
'if the current drawing is not saved

    If MsgBox("    OK to Save Drawing?", 4) = vbNo Then
    'ask the user what he wants to do
    
    End
    'if No end application
    
    Else
        acadDoc.Save
        'if Yes save the drawing
        
    End If
End If

sc = CDbl(TextBox1.Text)
'get the scale and convert to double


If Opt1.Value = True Then
'if this button selected

    DrgSheet = "E"
    'set first letter of drawing sheet
    
    templateFileName = "acadeng.dwt"
    'set the relevant template file
    
    Set doc = acadDoc.New(templateFileName)
    'open new drawing with selected template file
    
End If

If Opt2.Value = True Then
    DrgSheet = "A"
    templateFileName = "acadarch.dwt"
    Set doc = acadDoc.New(templateFileName)
End If

If Opt3.Value = True Then
    DrgSheet = "EL"
    templateFileName = "acadelec.dwt"
    Set doc = acadDoc.New(templateFileName)
End If

If Opt4.Value = True Then
    DrgSheet = "B"
    templateFileName = "acadblank.dwt"
    Set doc = acadDoc.New(templateFileName)
End If

Select Case ListBox1.ListIndex
'get the item selected from list box

Case 0
'if the index is 0 (first item)

    DrgSize = "A0"
    'set the drawing size
    
    newLimits(0) = 0#
    newLimits(1) = 0#
    newLimits(2) = 1189# * sc
    newLimits(3) = 841# * sc
    'set the limits
    
    Set oldTextStyle = acadDoc.ActiveTextStyle
    'get the current text style
    
Case 1
    DrgSize = "A1"
    newLimits(0) = 0#
    newLimits(1) = 0#
    newLimits(2) = 841# * sc
    newLimits(3) = 594# * sc
    Set oldTextStyle = acadDoc.ActiveTextStyle
Case 2
    DrgSize = "A2"
    newLimits(0) = 0#
    newLimits(1) = 0#
    newLimits(2) = 594# * sc
    newLimits(3) = 420# * sc
    Set oldTextStyle = acadDoc.ActiveTextStyle
Case 3
    DrgSize = "A3"
    newLimits(0) = 0#
    newLimits(1) = 0#
    newLimits(2) = 420# * sc
    newLimits(3) = 297# * sc
    Set oldTextStyle = acadDoc.ActiveTextStyle
Case 4
    DrgSize = "A4"
    newLimits(0) = 0#
    newLimits(1) = 0#
    newLimits(2) = 297# * sc
    newLimits(3) = 210# * sc
    Set oldTextStyle = acadDoc.ActiveTextStyle
End Select

acadDoc.Limits = newLimits
'set drawing limits

Set pViewport = acadDoc.ActiveViewport
'get reference to viewports

pViewport.ZoomExtents
'zoom to extents

Call acadDoc.SetVariable("Ltscale", sc * 10)
'set Ltscale

Call acadDoc.SetVariable("Dimscale", sc)
'set Dimscale

Call acadDoc.SetVariable("Userr1", sc)
'store scale in Userr1 for later use

Call acadDoc.SetVariable("Regenmode", 1)
'set Regenmode

Call acadDoc.SetVariable("Tilemode", 1)
'set Tilemode

oldTextStyle.Height = 3.5 * sc
'set Text Height

Insertsheet = DrgSheet & DrgSize
'String Drawing Sheet Name Together


InsertionPoint(0) = 0
InsertionPoint(1) = 0
InsertionPoint(2) = 0
'set the insertion point

Set Mspace = acadDoc.ModelSpace
'get reference to Model Space

Set Blockref = Mspace.InsertBlock(InsertionPoint, Insertsheet, sc, sc, 0)
'Insert the drawing sheet


'MsgBox ("Drawing Setup Complete"), , "AfraLisp Drawing Setup"


End
End Sub



Private Sub ListBox1_Click()
TextBox1.SetFocus

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
cmdOk_Click
End Sub

Private Sub Opt1_Click()
TextBox1.SetFocus
End Sub

Private Sub Opt2_Click()
TextBox1.SetFocus
End Sub

Private Sub Opt3_Click()
TextBox1.SetFocus
End Sub

Private Sub Opt4_Click()
TextBox1.SetFocus
End Sub

Private Sub UserForm_Initialize()
ListBox1.AddItem "A0 - 1189 x 841"
ListBox1.AddItem "A1 -  841 x 594"
ListBox1.AddItem "A2 -  594 x 420"
ListBox1.AddItem "A3 -  420 x 297"
ListBox1.AddItem "A4 -  297 x 210"
ListBox1.ListIndex = 0


End Sub