Saving solidworks drawings as PDF file with prefix - vb.net

I'm trying to save a solidworks drawing file using macros and adding a prefix to the PDF. The code works with adding everything after the it pulls the name of the file from solidworks, but it can't seem to add the prefix
CODE:
Dim swApp As Object
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swExportPDFData As SldWorks.ExportPdfData
Dim strFilename As String
Dim status As Boolean
Dim errors As Long, warnings As Long
Dim prefix As String
Dim CurrRev As String
Dim strFilenameShort As String
Dim TempString As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Save
status = swModel.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, errors, warnings)
'Export to PDF if it is a drawing
If (swModel.GetType = swDocDRAWING) Then
prefix = (InputBox("Enter Company Prefix"))
CurrRev = (InputBox("Enter Current Revision"))
strFilenameShort = swModel.GetPathName
strFilenameShort = Left(strFilenameShort, Len(strFilenameShort) - 7)
TempString = CStr(strFilenameShort)
strFilename = prefix & TempString & "REV" & CurrRev & ".PDF"
Set swExportPDFData = swApp.GetExportFileData(1)
swModel.Extension.SaveAs strFilename, 0, 0, swExportPDFData, 0, 0
End If
Set swApp = Application.SldWorks
End Sub

Hello Siddiq Khareghat,
in your example you are combining the prefix with the full path of TempString which is wrong because the result would be something like "prefixC:\...REV1.pdf"
Here is an example with multiple steps which extract the needed parts of the model pathname. At the end everything is combined with the prefix and CurrRev
' PathName of current model document
Dim sModelFullPath As String
sModelFullPath = swModel.GetPathName
' get path name without filename
Dim sFilePath As String
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
' get filename and extension
Dim sFileName As String
sFileName = Right(sModelFullPath, Len(sModelFullPath) - InStrRev(sModelFullPath, "\"))
' get filename without extension
Dim sFileNameWithoutExtension As String
sFileNameWithoutExtension = Left(sFileName, InStrRev(sFileName, ".") - 1)
' combine everything to new path name
Dim sNewFullPath As String
sNewFullPath = prefix & sFileNameWithoutExtension & "REV" & CurrRev & ".pdf"
' SaveAs with new full path
Set swExportPDFData = swApp.GetExportFileData(1)
swModel.Extension.SaveAs sNewFullPath, 0, 0, swExportPDFData, 0, 0

Related

VBA (API) save SOLIDWORKS drawing as PDF in a set location

I am trying to figure out how to modify my PDF saving macro so that instead of saving the PDF in the same folder as drawing, it would save it to a set location that's written out in macro.
The code I am working with is:
Sub Save_PDF()
'Declare variables
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swExportPDFData As SldWorks.ExportPdfData
Dim strFilename As String
Dim status As Boolean
Dim errors As Long, warnings As Long
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Export to PDF if it is a drawing
If (swModel.GetType = swDocDRAWING) Then
strFilename = swModel.GetPathName
strFilename = Left(strFilename, Len(strFilename) - 6) & "pdf"
Set swExportPDFData = swApp.GetExportFileData(1)
swModel.Extension.SaveAs strFilename, 0, 0, swExportPDFData, 0, 0
End If
End Sub
Would someone, please, help me with this one?
You just need to get the name of the file then concatenate with the rest of the path, and remove the unnecessary lines, like this:
Option Explicit
Sub Save_PDF()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim strFilename As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocDRAWING Then MsgBox ("Error: Not a drawing"): Exit Sub
strFilename = swModel.GetPathName
strFilename = "G:\45 Design\" & Mid(strFilename, InStrRev(strFilename, "\") + 1, InStrRev(strFilename, ".") - InStrRev(strFilename, "\")) & "pdf"
MsgBox "Save path : " & strFilename
swModel.Extension.SaveAs strFilename, 0, 0, Nothing, 0, 0
End Sub

opening html file with vba

I have some .html files which I want to read with vba. I wrote this codes to do what I want but I get
object variable or with block variable not set
error.
Dim arrListATA() As String
Dim arrListTaskNo() As String
Dim arrListDesc() As String
Dim arrIssueNo() As String
Dim arrIssueDate() As String
Dim arrPartNo() As String
Dim arrDMC() As String
Dim arrApplicability() As String
Dim arrDMCModelCode() As String
Dim DMCs As String
Dim arrSubTask() As String
Dim subTasks As String
Dim subs() As Variant
Dim subs1 As String
k = 0
Dim objFile As Scripting.File
Dim objFolder As Scripting.Folder
Set objFSO = CreateObject("Scripting.FileSystemObject")
w = 0
m = 0
b = 0
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
fd.Filters.Clear
If fd.Show = -1 Then
myTopFolderPath = fd.SelectedItems(1)
Set objFolder = objFSO.GetFolder(myTopFolderPath)
Dim arrSplitedDMC As Variant
Dim arrSubTasks As Variant
For Each objFile In objFolder.Files
Debug.Print myTopFolderPath & "\" & objFile.Name
If Right(objFile.Name, 4) = "html" And Len(objFile.Name) = 33 And Left(objFile.Name, 8) <> "V2500-00" Then
Debug.Print myTopFolderPath & "\" & objFile.Name
Workbooks.Open Filename:=myTopFolderPath & "\" & objFile.Name
Debug.Print "Opened"
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
taskCheckFlag = False
myTemp = ""
partNoFlag = False
mySubTask = ""
For i = 1 To lastrow
txt = Cells(i, 1)
Next i
My folder path and my object names like this
C:\Users\ftk1187\Desktop\V2500 - Copy\V2500-00-70-72-02-00A-363A-D.html
It's not opening my .html files. How can I solve this problem?
The code below actually runs.
Option Explicit
Private Sub Test()
Dim arrListATA() As String
Dim arrListTaskNo() As String
Dim arrListDesc() As String
Dim arrIssueNo() As String
Dim arrIssueDate() As String
Dim arrPartNo() As String
Dim arrDMC() As String
Dim arrApplicability() As String
Dim arrDMCModelCode() As String
Dim DMCs As String
Dim arrSubTask() As String
Dim subTasks As String
Dim subs() As Variant
Dim subs1 As String
Dim objFSO As FileSystemObject
Dim Fd As FileDialog
Dim objFile As Scripting.File
Dim objFolder As Scripting.Folder
Dim arrSplitedDMC As Variant
Dim arrSubTasks As Variant
Dim myTopFolderPath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
' k = 0
' w = 0
' m = 0
' b = 0
With Fd
.Filters.Clear
If .Show = -1 Then
myTopFolderPath = .SelectedItems(1)
Set objFolder = objFSO.GetFolder(myTopFolderPath)
For Each objFile In objFolder.Files
Debug.Print myTopFolderPath & "\" & objFile.Name
Debug.Print myTopFolderPath
Debug.Print objFile.Name
Debug.Print Right(objFile.Name, 4), Len(objFile.Name), Left(objFile.Name, 8)
' If Right(objFile.Name, 4) = "html" And Len(objFile.Name) = 33 And Left(objFile.Name, 8) <> "V2500-00" Then
' Debug.Print myTopFolderPath & "\" & objFile.Name
' Workbooks.Open Filename:=myTopFolderPath & "\" & objFile.Name
' Debug.Print "Opened"
'
' lastrow = Cells(Rows.Count, 1).End(xlUp).Row
' taskCheckFlag = False
' myTemp = ""
' partNoFlag = False
' mySubTask = ""
'
' For i = 1 To lastrow
' txt = Cells(i, 1)
' Next i
Next objFile
End If
End With
End Sub
You will see that I added Option Explicit at the top and a few declarations that were missing. The variables k, w, m and b are also not declared but if they are numbers their value should already be 0 at that point of the code. According to my research, Excel should be able to open an HTML file but I wonder what it might show.
As a general piece of advice, I would recommend that you construct your code as one Main subroutine which calls other subs and functions, each of them no larger than 10 to 25 lines of code. In your code you already exceed that number in your declarations. The effect is a construct that you can't control.

How to get the number of lines of data in CSV file in VBA

I tried to get the number of lines of data in several CSV files in VBA.
Here is the code.
Sub Woo_Products()
Dim fso As New FileSystemObject
Dim flds As Folders
Dim fls As Files
Dim strText As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim extfind As String
Dim FilePath As String
Dim sLineOfText As String
On Error Resume Next
Workbooks.Open Filename:="F:\Work\scrape\" & "woocommerce-products.csv", UpdateLinks:=3
Set fls = fso.getfolder("C:\Users\star\Downloads").Files
k = 2
For Each f In fls
strText = f.Name
extfind = Right$(strText, Len(strText) - InStrRev(strText, "."))
If extfind = "csv" Then
FilePath = "C:\Users\star\Downloads\" & strText
Open FilePath For Input As #1
i = 0
Do Until EOF(1)
Line Input #1, sLineOfText
If sLineOfText <> "" Then i = i + 1
Loop
Close #1
End If
Next
Windows("woocommerce-products.csv").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
But I am getting the same count for each file.
Of course, each file has different lines of data.
Hope to help me for this.
If all you need is a line count, I would write a function to return the count.
Function getFileLineCount(FullFileName As String, Optional LineDelimiter As String = vbNewLine) As Long
Dim text As String
Dim fileNo As Integer, n As Long
fileNo = FreeFile
Open FullFileName For Input As #fileNo
Do Until EOF(1)
Line Input #1, text
n = n + 1
Loop
Close #fileNo
getFileLineCount = n
End Function
Another approach using FileSystemObject:
Public Function GetLineCount(ByVal Path As String) As Long
With CreateObject("Scripting.FileSystemObject")
GetLineCount = UBound(Split(.OpenTextFile(Path, 1).ReadAll, vbNewLine)) + 1
End With
End Function
You'll need to add the references (Tools --> References)
Microsoft Scripting Runtime
Microsoft VBScript Regular Expressions 5.5
This will count "Return & NewLine" characters in the file.
Private Function LineCount(ByVal PathFile As String) As Long
Dim sData As String
Dim oFile As New FileSystemObject
sData = oFile.OpenTextFile(PathFile, ForReading).ReadAll
Dim oRegX As New RegExp
oRegX.Pattern = "\r\n"
oRegX.Global = True
LineCount = oRegX.Execute(sData).Count + 1
Set oRegX = Nothing
Set oFile = Nothing
End Function
i = ActiveWorkbook.ActiveSheet.Cells(ActiveWorkbook.ActiveSheet.Rows.Count, 1).End(xlUp).Row
It's working so well.

Excel VBA open workbook with part of its name

I want to open, using VBA, a workbook from a certain path that includes a number, for example 2. Any variation I tried is not working.
The name of the workbook is in Hebrew except for the number, so I want the VBA code to base the file name on the number to open the file.
I have 4 letters in hebrew before the number. In Hebrew we write from right to left.
Here is my code:
Set WB1 = Workbooks.Open("C:\RESULTS\" 2 & ".xlsx")
Thanks for helping.
Try this
Dim sFound As String, fPath As String
fPath = "C:\RESULTS\"
sFound = Dir(fPath & "*2*.xlsx") 'get the first file in dir
If sFound <> "" Then
Set WB1 = Workbooks.Open(fPath & sFound)
End If
This works for me:
Option Explicit
Sub TestMe()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wbs As Workbook
Dim strExtension As String
Dim lngNumber As String
Dim lngAdditional As Long
Dim lngLenFile As Long
strExtension = ".xlsx"
lngNumber = 20
lngAdditional = 4
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Desktop\")
lngLenFile = Len(strExtension) + Len(lngNumber) + lngAdditional
For Each objFile In objFolder.Files
If Left(objFile.Name, Len(lngNumber)) = lngNumber And _
Right(objFile, Len(strExtension)) = strExtension And _
Len(objFile.Name) = lngLenFile Then
Debug.Print objFile.Name
Set wbs = Workbooks.Open(objFile)
End If
Next objFile
End Sub
The idea of the code is to make it flexible, thus, lngNumber and strExtension are added. It checks always for the size, as well as for right and left. Thus 24Some.xlsx would be different than 2Some.xlsx.
Debug.Print is added to see the file that is opened.
lngAdditional is added, for the additional 4 chars.

How to change the name of a file as it is unzipped using VBA

I am unzipping a file in a folder, and saving in a new location. How do I rename that file immediately after unzipping it? After unzipping I will have a file like 1234_data.csv, how do I rewrite that as whatiwant.csv ?
I am aware I need to use a line such as Name oldfile As NewFileName
Sub Unzip1(str_FILENAME As String)
Dim oApp As Object
Dim Fname As Variant
Dim FnameTrunc As Variant
Dim FnameLength As Long
'Fname = str_FILENAME 'Commented out to show example file name
Fname = "file.zip"
FnameLength = Len(Fname)
If Fname = False Then
'Do nothing
Else
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace("C:\Users\Andrew\folder").CopyHere oApp.NameSpace(Fname).Items
DoEvents
End If
End Sub
strPath = “c:\tempzips\”
Fname = "new_file_name.zip"
If Len(Fname) Then
Name strPath + "original.zip" As strPath + Fname
End If
Alternate based on comment
Sub post_unzip(str_just_unzipped_filename As String, str_new_filename As String)
str_path = "c:\thepathtothezips\"
Name strpath + str_just_unzipped_filename As strpath + str_new_filename
End Sub