Autocad Script Generator 3

screenshot_7

complete code

Autocad Script Generator

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
 

screenshot_8

and finally dont forget
screenshot_9

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s