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
Related
I want to store the dimension name (string) in the form of the array so that I can compare another array (dimension name) to the current.
Public Sub WhateverName
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swPart As PartDoc
Dim swFeat As Feature
Dim swDispDim As DisplayDimension
Dim swDim As Dimension
Dim vDimVals As Variant
Dim swDimInfoNameArr As Variant
Dim SKETCH_NAME As String
Dim i As Variant
Dim swDimName As Variant
Dim swDispDimname As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swPart = swModel
SKETCH_NAME = "ISO Standard"
Set swFeat = swPart.FeatureByName(SKETCH_NAME)
Set swDispDim = swFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
i = 0
'For i = 0 To 4
Set swDim = swDispDim.GetDimension2(Empty)
vDimVals = swDim.GetValue3(swThisConfiguration, Empty)
Debug.Print swDim.Name & "#" & SKETCH_NAME & ": " & Round(vDimVals(0), 6)
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
swDimName = swDim.Name
swDimInfoNameArr(i) = swDimName 'swModel.GetCustomInfoNames2 --> ERROR
i = i + 1
'Next
Loop
End Sub
27th line is throwing the error "Type Mismatch"
You need to declare the size of the array, or use an other object to store. Like a dictionnary:
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swPart As PartDoc
Dim swFeat As Feature
Dim swDispDim As DisplayDimension
Dim swDim As Dimension
Dim vDimVals As Variant
Dim SKETCH_NAME As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swPart = swModel
SKETCH_NAME = "ISO Standard"
Set swFeat = swPart.FeatureByName(SKETCH_NAME)
Set swDispDim = swFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
Set swDim = swDispDim.GetDimension2(Empty)
vDimVals = swDim.GetValue3(swThisConfiguration, Empty)
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
dict.Add swDim.Name, Round(vDimVals(0), 6)
Debug.Print dict.keys()(dict.Count - 1) & "#" & SKETCH_NAME & ": " & dict.Items()(dict.Count - 1)
Loop
End Sub
I simply need to open the drawing by using VBA of the active part. Drawing always has the exact same filename and location as the part. What I got is
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swDocSpecification As SldWorks.DocumentSpecification
Dim sName As String
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swDocSpecification = swApp.GetOpenDocSpec("C:\Users\Public\Documents\SOLIDWORKS\SOLIDWORKS
2017\tutorial\AutoCAD\7550-021.slddrw")
sName = swDocSpecification.FileName
swDocSpecification.DocumentType = swDocDRAWING
swDocSpecification.ReadOnly = True
swDocSpecification.Silent = False
Set swModel = swApp.OpenDoc7(swDocSpecification)
longstatus = swDocSpecification.Error
longwarnings = swDocSpecification.Warning
End Sub
But it doesn't work probably because of the file location which may always be different depending on how the active part is named and where the active part is located.
Could someone please share a function to simply open the associated drawing of the part?
Try this:
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.ModelDoc2
Dim swDocSpecification As SldWorks.DocumentSpecification
Dim FilePath As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Open an assembly or part": Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocASSEMBLY And swModel.GetType <> swDocumentTypes_e.swDocPART Then MsgBox "Open an assembly or part": Exit Sub
Set swDocSpecification = swApp.GetOpenDocSpec(swModel.GetPathName)
FilePath = LCase(swModel.GetPathName)
FilePath = Replace(FilePath, ".sldprt", ".slddrw")
FilePath = Replace(FilePath, ".sldasm", ".slddrw")
swDocSpecification.FileName = FilePath
swDocSpecification.DocumentType = swDocumentTypes_e.swDocDRAWING
swDocSpecification.ReadOnly = True
swDocSpecification.Silent = True
Set swDraw = swApp.OpenDoc7(swDocSpecification)
swApp.ActivateDoc3 FilePath, False, swRebuildOnActivation_e.swRebuildActiveDoc, Empty
End Sub
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
New to VBA and initially my problem was to copy text in CSV file into string and then ultimately to a master workbook. I used the below code which works perfectly:
Sub Compiler()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim MyPath As String
Dim strFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
MyPath = "W:\Test Folder\"
strFilename = Dir(MyPath, vbNormal)
Do While strFilename <> ""
Dim buffer As String
Open MyPath & strFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
'Application.CutCopyMode = False
strFilename = Dir()
Loop
End Sub
However, for some reason, it only copy pastes some of the files and not others (or maybe it overwrites it?, point is some of the files are not copied in). Not sure why this is the case? Is it because there are some blank cells in files? To rectify this, i replaced all blank cells with 0 - didn't work. Is it because of different copy paste area? Don't know how to rectify that if this is the case
So after long investigation, i found out an impractical approach where if you paste in files that you need to copy one by one, It does the trick but it is inefficient. So just for a temp solution, i did the following where vba code copies in a file from a temp folder to the source folder, does its job of copy pasting to the master work book and then deletes the file that was copied in. For some reason, the code stops at the first even though it's a Do while loop. Not sure what's the problem here and what is most efficient approach here?
Sub ISINCompiler()
'Declare Variables
Dim FSO
Dim MyPath As String
Dim strFilename As String
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Test Folder\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
Do While strFilename <> ""
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
ISINCompilerx2 '<-Copying and pasting in text
DeleteExample1 '<-Deleting the file after it has been copied in
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
strFilename = Dir()
Loop
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim someotherpath As String
Dim somestrFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
someotherpath = "W:\Test Folder\"
somestrFilename = Dir(someotherpath, vbNormal)
Do While somestrFilename <> ""
Dim buffer As String
Open someotherpath & somestrFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire
contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
somestrFilename = Dir()
Loop
End Sub
Private Sub DeleteExample1()
On Error Resume Next
Kill "W:\Test Folder\*.*"
On Error GoTo 0
End Sub
new Code:
Sub ISINCompiler()
'Declare Variables
Dim FSO As Object
Dim MyPath As String
Dim strFilename As String
Dim f As Object
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Destination folder\"
' Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
For Each f In FSO.GetFolder(MyPath).Files
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
'ISINCompilerx2
'DeleteExample1
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
Next f
Set f = Nothing
Set FSO = Nothing
End Sub
You can simplify your code;
Dim Filename As String
Dim lLastRow As Long
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Worksheets("First Sheet")
Filename = Dir("W:\Test Folder\*.csv")
Do While Filename <> ""
Set wbSrce = Workbooks.Open(Filename)
lLastRow = wsDst.UsedRange.Rows.Count + 1
wbSrce.Sheets(1).UsedRange.Copy wsDst.Range("A" & lLastRow)
wbSrce.Close savechanges:=False
Filename = Dir
Loop
So i found out that Dir was the problem so i just removed dir in my main macro
Option Explicit
Public wbDst As Workbook
Public wsDst As Worksheet
Sub ISINCompiler()
'Declare Variables
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
Dim i As Long
Dim myFSO As FileSystemObject
Dim xFolder As Scripting.Folder
Dim FSO As Object
Dim f
Dim MyPath As String
Dim sDFolder As String
Application.DisplayAlerts = False
sDFolder = "W:\Destination\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFSO = New FileSystemObject
Set xFolder = myFSO.GetFolder("C:\Source")
'Checking If File Is Located in the Source Folder
For Each f In xFolder.Files
f.Copy sDFolder & f.Name
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
ISINCompilerx2
DeleteExample1
Next f
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim lLastRow As Long
Dim somePath As String
Dim someFilename As String
handle = FreeFile
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
somePath = "W:\Destination\"
someFilename = Dir(somePath, vbNormal)
Dim buffer As String
Open somePath & someFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of
the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
End Sub
Private Sub DeleteExample1()
'You can use this to delete all the files in the folder Test
On Error Resume Next
Kill "W:\Destination\*.*"
On Error GoTo 0
End Sub
I want to access each subfolder of my current folder(number of subfolders in each sub folder may vary) and then want to perform some operations in each excel workbook of all these subfolders.
Below mentioned is the code and code is not throwing compile time error but not working. Kindly help me
option explicit
Sub LoopFolders()
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim wbk As Workbook
' Parent folder including trailing backslash
strFolder = "C:\Users\Yashika Vaish\Desktop\yashika\"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through Excel workbooks in subfolder
strFile = Dir(strFolder & varItem & "\*.xls*")
Do While strFile <> ""
' Open workbook
Set wbk = Workbooks.Open(FileName:=strFolder & _
varItem & "\" & strFile, AddToMRU:=False)
MsgBox "I am open"
strFile = Dir
Loop
Next varItem
End Sub
All the required references in tools settings have already been added in this VBA Project. Kindly help me with this code.
The method below writes the file names from the subfolders too to the workbook. So it finds them.
Sub Program()
Dim i As Integer
i = 1
listFiles "D:\Folder 1", i
End Sub
Sub listFiles(ByVal sPath As String, ByRef i As Integer)
Dim vaArray As Variant
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files
If (oFiles.Count > 0) Then
ReDim vaArray(1 To oFiles.Count)
For Each oFile In oFiles
Cells(i, "A").Value = oFile.Name
Cells(i, "B").Value = oFile.Path
i = i + 1
Next
End If
listFolders sPath, i
End Sub
Sub listFolders(ByVal sPath As String, ByRef i As Integer)
Dim vaArray As Variant
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.subfolders
If (oFiles.Count > 0) Then
ReDim vaArray(1 To oFiles.Count)
For Each oFile In oFiles
listFiles oFile.Path, i
i = i + 1
Next
End If
End Sub
This is what I use & it's a #WorksAtMyBox certified code ;)
Option Explicit
Dim fso As Scripting.FileSystemObject
Dim fsoMainDirectory As Scripting.folder
Dim fsoSubfolder As Scripting.folder
Dim fsoFile As Scripting.file
Dim strFilePath
Dim filecounter As Long
Dim foldercounter As Long
Public Sub FileFinder(fileorfolder As String)
If fso Is Nothing Then
Set fso = New Scripting.FileSystemObject
End If
Set fsoMainDirectory = fso.GetFolder(fileorfolder)
If fsoMainDirectory.SubFolders.Count > 0 Then
For Each fsoSubfolder In fsoMainDirectory.SubFolders
foldercounter = foldercounter + 1
Debug.Print "Folder: " & foldercounter & fsoSubfolder.Path
FileFinder (fsoSubfolder.Path)
Next fsoSubfolder
End If
If fsoMainDirectory.Files.Count > 0 Then
For Each fsoFile In fsoMainDirectory.Files
ProcessFile (fsoFile.Path)
Next fsoFile
End If
End Sub
Public Sub ProcessFile(file As String)
filecounter = filecounter + 1
Debug.Print "File: " & filecounter & ": " & file
End Sub
So, here is how I search through a folder looking for a specific file type. (early binding is your friend at this point in development). Make sure you have the Microsoft Scripting Runtime reference enabled.
Option Explicit
Sub test()
Dim fso As Scripting.FileSystemObject
Dim fsoMainDirectory As Scripting.Folder
Dim fsoSubfolder As Scripting.Folder
Dim fsoFile As Scripting.File
Dim strFilePath
Set fso = New Scripting.FileSystemObject
Set fsoMainDirectory = fso.GetFolder("Directory, with trailing \")
For Each fsoFile In fsoMainDirectory.Files
If fsoFile.Type = "Microsoft Excel 97-2003 Worksheet" Then '.xls file type
strFilePath = fsoFile.Path
Application.Workbooks.Open strFilePath
End If
Next fsoFile
End Sub
How deep do your sub folders go? Are you the only one will use this macro? Looping through n subfolders with an unknown number of subfolders is doable, but my method involves an array of counters. This array can lower performance, and as such don't want to do that if we don't need to.