Frfly



Autocad Script Generator terry priest 1/9/20164829175311785Cmd_open_explorerse_files00Cmd_open_explorerse_files7048500619125Cbo_script_select00Cbo_script_select48196501304925Cmd_make_acad_script00Cmd_make_acad_script18192754019550Cmd_run_pdf100Cmd_run_pdf12476503590925cmd_run_plot100cmd_run_plot167151251581150Txt_script_title00Txt_script_titleright2133600Lb_script_list00Lb_script_list10001251629410Lb_file_list00Lb_file_list2876550723900Txt_job_folder00Txt_job_folder4286259525Cmd_choose_files00Cmd_choose_filesForm CodeOption ExplicitPrivate Sub cmd_choose_files_Click()Call ChooseFilesEnd SubPrivate Sub cmd_open_explorer_Click()Call openexplorer(str_dir)End SubPrivate Sub cmd_make_acad_script_Click()Call make_acad_scrEnd SubPrivate Sub cmd_run_plot1_Click()Call run_plot1End SubPrivate Sub cmd_run_pdf1_Click()Call run_pdf1End SubPrivate Sub CommandButton1_Click()MsgBox "written by T Priest 2015"End SubPrivate Sub cmd_close_Click()Unload MeEnd SubPrivate 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_titleEnd SubPrivate Sub UserForm_Initialize()'gets the value from spreadsheet, writes it to public var'then writes it to formstr_dir = ActiveWorkbook.Worksheets("Job_List").Range("B1").ValueMe.txt_job_folder.Text = str_dir'fills public array with list of alpha script titles'fill script select combo.List with arrayCall get_alpha_listcbo_script_select.List = ar_alphaEnd SubModule1Option 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.ShowEnd SubSub 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 IfSet fd = NothingEnd SubSub openexplorer(strdir)Shell "C:\WINDOWS\explorer.exe """ & strdir & "", vbNormalFocusEnd SubSub 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 IfEnd SubFunction 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 FunctionModule2Option Explicit'form button make acad_scr in job folderSub 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.CloseEnd SubSub 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 iEnd SubSub 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 iEnd SubModule3Option Explicit'hardwire routinesSub 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"), 1End SubSub 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"), 1End SubPublic Sub Opn_dwg(strdwg As String) On Error Resume Next Set acad_dwg = acadApp.Documents.Open(strdwg) 'acadApp.Visible = True 'On Error GoTo 0End SubModule4Function pnl_str() As StringDim str As Stringstr = "-plot" & vbCrstr = str & "Yes" & vbCrstr = str & "Model" & vbCrstr = str & "MFG M712" & vbCrstr = str & "Letter" & vbCrstr = str & "Inches" & vbCrstr = str & "Landscape" & vbCrstr = str & "No" & vbCrstr = str & "Limits" & vbCrstr = str & "Fit" & vbCrstr = str & "Center" & vbCrstr = str & "Yes" & vbCrstr = str & "Eng Xerox.ctb" & vbCrstr = str & "Yes" & vbCrstr = str & "A" & vbCrstr = str & "No" & vbCr 'write the plot to a filestr = str & "Yes" & vbCr 'save changes to page setupstr = str & "Yes" & vbCr 'proceedpnl_str = strEnd FunctionFunction pdf_str(ByVal str_fname As String) As StringDim str As StringDim str_fname_strip As Stringstr_fname_strip = Left(str_fname, InStrRev(str_fname, ".") - 1)str = "-plot" & vbCrstr = str & "y" & vbCrstr = str & "Model" & vbCrstr = str & "DWG To PDF.pc3" & vbCrstr = str & "ANSI A (11.00 x 8.50 Inches)" & vbCrstr = str & "Inches" & vbCrstr = str & "Landscape" & vbCrstr = str & "No" & vbCrstr = str & "Limits" & vbCrstr = str & "Fit" & vbCrstr = str & "Center" & vbCrstr = str & "Yes" & vbCr 'plot stylesstr = str & "Eng Xerox.ctb" & vbCrstr = str & "Yes" & vbCr 'lineweightsstr = str & "A" & vbCrstr = str & str_fname_strip & vbCrstr = str & "Yes" & vbCr 'save changesstr = str & "Yes" & vbCr 'proceedstr = str & "Yes" & vbCr'extra yes to overwrite otherwise harmlesspdf_str = str End Function ................
................

In order to avoid copyright disputes, this page is only a partial summary.

Google Online Preview   Download