Autocad Script Generator terry priest 1/9/2016
Form Code
Option Explicit
Private Sub cmd_choose_files_Click()
Call ChooseFiles
End Sub
Private Sub cmd_open_explorer_Click()
Call openexplorer(str_dir)
End Sub
Private Sub cmd_make_acad_script_Click()
Call make_acad_scr
End Sub
Private Sub cmd_run_plot1_Click()
Call run_plot1
End Sub
Private Sub cmd_run_pdf1_Click()
Call run_pdf1
End Sub
Private Sub CommandButton1_Click()
MsgBox "written by T Priest 2015"
End Sub
Private Sub cmd_close_Click()
Unload Me
End Sub
Private Sub cbo_script_select_Change()
'sets str_alpha public var
str_alpha = frm_acad_script.cbo_script_select.Text
'fills ar_script public array with script body
Call get_script_body
With frm_acad_script.LB_Script_list
.Clear
.List = ar_script
End With
'sets public str_title from spreadsheet
With Sheets("Script-Template")
str_title = .Range(str_alpha & "1")
End With
frm_acad_script.txt_Script_Title = str_title
End Sub
Private Sub UserForm_Initialize()
'gets the value from spreadsheet, writes it to public var
'then writes it to form
str_dir = ActiveWorkbook.Worksheets("Job_List").Range("B1").Value
Me.txt_job_folder.Text = str_dir
'fills public array with list of alpha script titles
'fill script select combo.List with array
Call get_alpha_list
cbo_script_select.List = ar_alpha
End Sub
Module1
Option Explicit
Public acadApp As AcadApplication
Public acadDoc As AcadDocument 'used with connect_acad
'used in hardwire routines - set with opn_dwg
Public acad_dwg As AcadDocument
Public str_dir As String 'is B1 value
Public ar_x() As String 'string array of selected of file names
Public ar_alpha() As String 'string array of alpha script titles
Public str_alpha As String 'string of currently selected alpha script title
Public str_title As String 'string of currently selected descriptive script title
Public ar_script() As String 'string array of currently selected script body
Public FSO As New FileSystemObject
Sub show_form()
frm_acad_script.Show
End Sub
Sub ChooseFiles()
Dim FileChosen As Integer
Dim i As Integer
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'i cant get initialview to do anything
'it comes up in windows last used mode period
fd.InitialView = msoFileDialogViewDetails
fd.Filters.Add "DWG file", "*.dwg"
fd.InitialFileName = str_dir
fd.Title = "Choose Drawings"
fd.ButtonName = "Select DWGs"
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
ReDim ar_x(1 To fd.SelectedItems.Count)
For i = 1 To fd.SelectedItems.Count
ar_x(i) = fd.SelectedItems.Item(i)
Next i
frm_acad_script.lb_file_list.List = ar_x
str_dir = FolderFromPath(fd.SelectedItems(1))
frm_acad_script.txt_job_folder = str_dir
With Sheets("Job_List")
.Range("B1").Value = str_dir
End With
Else
'nothing to do, user pressed cancel
End If
Set fd = Nothing
End Sub
Sub openexplorer(strdir)
Shell "C:\WINDOWS\explorer.exe """ & strdir & "", vbNormalFocus
End Sub
Sub connect_acad()
'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If acadApp Is Nothing Then
'Set acadApp = CreateObject("AutoCAD.Application")
Set acadApp = New AcadApplication
acadApp.Visible = True
End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0
'If there is no active drawing create a new one.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
acadApp.Visible = True
End If
On Error GoTo 0
'Check if the active space is paper space and change it to model space.
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
End If
End Sub
Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Public Function FolderFromPath(strFullPath As String) As String
FolderFromPath = Left(strFullPath, InStrRev(strFullPath, "\"))
End Function
Module2
Option Explicit
'form button make acad_scr in job folder
Sub make_acad_scr()
Dim i As Integer, j As Integer
Dim file_str As String, script_str As String, str As String
Dim str_scr_filename As String
Dim fso_txtstream As TextStream
'read the array not contents of listbox
'check for file list and array list
'all public vars should be initialized
If IsArrayAllocated(ar_x) And IsArray(ar_x) And _
IsArrayAllocated(ar_script) And str_alpha > "" And str_dir > "" Then
'ok nothing
Else
MsgBox "File list empty or script not selected"
Exit Sub
End If
str_scr_filename = str_dir & "acad_script.scr" 'name of file to be created
Set fso_txtstream = FSO.CreateTextFile(str_scr_filename, True) 'True to overwrite existing
fso_txtstream.Close
Set fso_txtstream = FSO.OpenTextFile(str_scr_filename, ForAppending, False, False)
'open for writing, do not create if does not exist, open as ascii
'read the file array
For i = LBound(ar_x) To UBound(ar_x)
file_str = ar_x(i)
For j = 1 To UBound(ar_script)
script_str = ar_script(j)
Select Case script_str
Case "<path_filename_ext>"
'quotations around string to read names with spaces
fso_txtstream.WriteLine Chr(34) & file_str & Chr(34)
Case "<path_filename>"
str = Left(file_str, InStrRev(file_str, ".") - 1)
fso_txtstream.WriteLine Chr(34) & str & Chr(34)
Case Else
fso_txtstream.WriteLine script_str
End Select
Next j
Next i
fso_txtstream.Close
End Sub
Sub get_script_body()
'uses str_alpha public var to fill array ar_script with body text
Dim lastrow As Long
Dim rng As Range
Dim i As Integer
With Sheets("Script-Template")
lastrow = .Cells(.Rows.Count, str_alpha).End(xlUp).row
Set rng = .Range(str_alpha & "2", str_alpha & lastrow)
'Debug.Print rng.Address
End With
ReDim ar_script(1 To rng.Rows.Count)
For i = 1 To rng.Rows.Count
'Debug.Print rng.Cells(i, 1)
ar_script(i) = rng.Cells(i, 1)
Next i
End Sub
Sub get_alpha_list()
'fills array ar_alpha with alpha script titles from spreadsheet
'called by form initialize
Dim lastalpha As Long
Dim str As String
Dim i As Integer
With Sheets("Script-Template")
lastalpha = .Range("A1").End(xlToRight).Column
End With
ReDim ar_alpha(1 To lastalpha)
For i = 1 To lastalpha
str = Chr(i + 64)
ar_alpha(i) = str
Next i
End Sub
Module3
Option Explicit
'hardwire routines
Sub run_plot1()
Call connect_acad 'because need a connection to active drawing
Dim i As Integer
Dim str As String
acadDoc.SetVariable ("filedia"), 0
If IsArrayAllocated(ar_x) And IsArray(ar_x) Then
'nothing
Else
MsgBox "File list empty"
Exit Sub
End If
str = pnl_str()
For i = LBound(ar_x) To UBound(ar_x)
Opn_dwg (ar_x(i))
acad_dwg.SendCommand str
If acad_dwg.Name > "" Then
acad_dwg.Close False
End If
Next i
acadDoc.SetVariable ("filedia"), 1
End Sub
Sub run_pdf1()
Call connect_acad 'because need a connection to active drawing
Dim i As Integer
Dim str As String
acadDoc.SetVariable ("filedia"), 0
If IsArrayAllocated(ar_x) And IsArray(ar_x) Then
'nothing
Else
MsgBox "File list empty"
Exit Sub
End If
For i = LBound(ar_x) To UBound(ar_x)
Opn_dwg (ar_x(i))
str = pdf_str(ar_x(i))
acad_dwg.SendCommand str
If acad_dwg.Name > "" Then
acad_dwg.Close False
End If
Next i
acadDoc.SetVariable ("filedia"), 1
End Sub
Public Sub Opn_dwg(strdwg As String)
On Error Resume Next
Set acad_dwg = acadApp.Documents.Open(strdwg)
'acadApp.Visible = True
'On Error GoTo 0
End Sub
Module4
Function pnl_str() As String
Dim str As String
str = "-plot" & vbCr
str = str & "Yes" & vbCr
str = str & "Model" & vbCr
str = str & "MFG M712" & vbCr
str = str & "Letter" & vbCr
str = str & "Inches" & vbCr
str = str & "Landscape" & vbCr
str = str & "No" & vbCr
str = str & "Limits" & vbCr
str = str & "Fit" & vbCr
str = str & "Center" & vbCr
str = str & "Yes" & vbCr
str = str & "Eng Xerox.ctb" & vbCr
str = str & "Yes" & vbCr
str = str & "A" & vbCr
str = str & "No" & vbCr 'write the plot to a file
str = str & "Yes" & vbCr 'save changes to page setup
str = str & "Yes" & vbCr 'proceed
pnl_str = str
End Function
Function pdf_str(ByVal str_fname As String) As String
Dim str As String
Dim str_fname_strip As String
str_fname_strip = Left(str_fname, InStrRev(str_fname, ".") - 1)
str = "-plot" & vbCr
str = str & "y" & vbCr
str = str & "Model" & vbCr
str = str & "DWG To PDF.pc3" & vbCr
str = str & "ANSI A (11.00 x 8.50 Inches)" & vbCr
str = str & "Inches" & vbCr
str = str & "Landscape" & vbCr
str = str & "No" & vbCr
str = str & "Limits" & vbCr
str = str & "Fit" & vbCr
str = str & "Center" & vbCr
str = str & "Yes" & vbCr 'plot styles
str = str & "Eng Xerox.ctb" & vbCr
str = str & "Yes" & vbCr 'lineweights
str = str & "A" & vbCr
str = str & str_fname_strip & vbCr
str = str & "Yes" & vbCr 'save changes
str = str & "Yes" & vbCr 'proceed
str = str & "Yes" & vbCr
'extra yes to overwrite otherwise harmless
pdf_str = str
End Function