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
|