Hi all,

I am making a macro that opens all parts and their associated drawings from an open assembly, converts these drawings to DXF and PDF, converts the original assembly to STEP and then puts all these in a temporary folder named SUBCON within the same filepath as the original assembly. These files are then copied to an empty zip file. I am having issues with the zip file part. I have got it to a point where it can create the zip succesfully from a specific filepath, however this is going to be used company wide and therefore the filepath will not always be the same.Essentially i need a line of code that asks the program to look into the filepath that the assembly is located in and look for a subfolder named "subcon", get all the files within this "subcon" folder and then copy them to an empty zip file . Below i will attach the code. 

'Muhammad Ameen Adam
'This macro will allow the user to export all drawings within a top level assembly to DXF and PDF and then export the orginal assembly as a STEP._
'All files will be subsequently place in a seperate folder named 'subcon'. This folder will be located within the original folder.

'Preconditions

'There must be an assembly open in the solidworks window
'Each part within the assembly must have an associated drawing.
'Original assembly and all associated drawings and parts must be located within the same folder as each other

Option Explicit

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Dim swExportPDFData As SldWorks.ExportPdfData


Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String

Dim SH As Shell32.Shell
Dim F As Shell32.Folder

Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
BrowseFolder = F.Items.Item.Path
End If

End Function

Sub ShowAllOpenFiles()
Dim swDoc As SldWorks.ModelDoc2
Dim swAllDocs As EnumDocuments2
Dim FirstDoc As SldWorks.ModelDoc2
Dim NumDocsReturned As Long
Dim DocCount As Long
Dim swApp As SldWorks.SldWorks
Dim bDocWasVisible As Boolean
Dim OpenWarnings As Long
Dim OpenErrors As Long
Dim DwgPath As String
Dim myDwgDoc As SldWorks.ModelDoc2
Dim drwPathName As String
Dim pdfPathName As String
Dim pdfFolderName As String
Dim lErrors As Long
Dim lWarnings As Long
Dim sMessage As String
Dim nExported As Integer
Dim fso As Scripting.FileSystemObject
Dim CompConfig As String
Dim swDraw As SldWorks.DrawingDoc
Dim sFileName As String
Dim nFileName As String
Dim sPathName As String
Dim swModel As SldWorks.ModelDoc2

Set swApp = Application.SldWorks
Set swAllDocs = swApp.EnumDocuments2
Set FirstDoc = swApp.ActiveDoc

On Error Resume Next

If (FirstDoc.GetType <> swDocASSEMBLY) And (FirstDoc.GetType <> swDocPART) Then
MsgBox "This macro only works when run from an assembly"

Exit Sub
End If

CompConfig = FirstDoc.ConfigurationManager.ActiveConfiguration.Name

nExported = 0
DocCount = 0
swAllDocs.Reset
swAllDocs.Next 1, swDoc, NumDocsReturned
While NumDocsReturned <> 0
bDocWasVisible = swDoc.Visible
DwgPath = swDoc.GetPathName

If (LCase(Right(DwgPath, 3)) <> "drw") And (DwgPath <> "") Then
DwgPath = Left(DwgPath, Len(DwgPath) - 3) & "drw"
Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)

If Not myDwgDoc Is Nothing Then
swApp.ActivateDoc myDwgDoc.GetPathName



pdfFolderName = Left(DwgPath, InStrRev(DwgPath, "\")) & "Subcon\"

Set fso = CreateObject("Scripting.FileSystemObject")

If (Not fso.FolderExists(pdfFolderName)) Then
MkDir pdfFolderName
End If

Dim Part As ModelDoc2
Set Part = swApp.ActiveDoc()


drwPathName = Part.GetPathName()

If ("" = drwPathName) Then
MsgBox ("This drawing has not been saved yet")
Exit Sub
End If

'Save as .PDF
pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) & "-" & CompConfig & ".pdf")

Set swExportPDFData = swApp.GetExportFileData(1)
swExportPDFData.ViewPdfAfterSaving = False
Part.Extension.SaveAs pdfPathName, 0, 0, swExportPDFData, lErrors, lWarnings

'Save as .DXF
pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) & "-" & CompConfig & ".dxf")

Set swExportPDFData = swApp.GetExportFileData(2)
swExportPDFData.ViewPdfAfterSaving = False
Part.Extension.SaveAs pdfPathName, 0, 0, swExportPDFData, lErrors, lWarnings

swApp.QuitDoc (Part.GetTitle)
Set myDwgDoc = Nothing
nExported = nExported + 1

End If
End If

swAllDocs.Next 1, swDoc, NumDocsReturned
DocCount = DocCount + 1
Wend

'Message box to tell user how many files have been exported

sMessage = "PDF/DXF/BOM Export " & vbCr & vbCr
If nExported = 0 Then
sMessage = sMessage & "No Drawings found to export to PDF" & vbCr & vbCr
Else
sMessage = sMessage & CStr(nExported) & " PDF's saved to: " & vbCr & pdfFolderName & vbCr & vbCr
End If



swApp.ActivateDoc FirstDoc.GetPathName


Call STEP

Call ZIP

End Sub

Sub STEP()

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swExportData As SldWorks.ExportPdfData
Dim boolstatus As Boolean
Dim filename As String
Dim lErrors As Long
Dim lWarnings As Long
Dim Part As Object
Dim strNewPath As String
Dim currExtension As String
Dim newExtension As String
Dim lngErrors As Long
Dim lngWarnings As Long
Dim Path As String

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set Part = swApp.ActiveDoc
Dim FilePath As String
Dim PathSize As Long
Dim PathNoExtention As String
Dim NewFilePath As String
Dim sPath As String
Dim vConfNameArr As Variant
Dim i As Long
Dim sConfigName As String
Dim bShowConfig As Boolean
Dim sDate As String
Dim bRebuild As Boolean

Set swApp = CreateObject("SldWorks.Application")

If swModel.GetType = swDocDRAWING Then
End
Else
If swModel.GetType = swDocASSEMBLY Then

'Get Configuration Details and Name
vConfNameArr = swModel.GetConfigurationNames
For i = 0 To UBound(vConfNameArr)
sConfigName = vConfNameArr(i)

bShowConfig = swModel.ShowConfiguration2(sConfigName)
bRebuild = swModel.ForceRebuild3(False)

sPath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\"))

'Check and make a subfolder in same path
If Len(Dir(sPath & "Subcon", vbDirectory)) = 0 Then
MkDir sPath & "\Subcon"
End If

sPath = sPath & "Subcon" & "\"

'Set Date Format
sDate = Format(Now, "yyyy-mm-dd")

'Save file as STEP
swModel.SaveAs (sPath & "_" & ".STEP")

Next i

Part.SaveAs2 NewFilePath, 0, True, False
MsgBox "Saved " & NewFilePath

End If
End If
End Sub

Sub ZIP()

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim sTempFolder As String
Dim sModelFolder As String
Dim vZipPath As Variant
Dim sModelName As String
Dim bRebuild As Boolean
Dim Path As String
Dim currExtension As String
Dim newExtension As String
Dim strNewPath As String

Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc

' *** Change this path to use a different temp folder ***


sTempFolder = "\\BLAS0003\data$\Solidworks\Standard Components\Spring Seal\Piston Spring Seals\Z95X PS-026760-0770-0790-IN\Tooling\Subcon"

'Check a file is Open
If swModel Is Nothing Then
swApp.SendMsgToUser2 "Please open a part or assembly file!", swMbWarning, swMbOk
Exit Sub
End If

'Force Rebuild and Save
bRebuild = swModel.ForceRebuild3(False)
swModel.Save

'Get zip file path
vZipPath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\"))
'Get File Name Without extension
sModelName = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1)
sModelName = Left(sModelName, InStrRev(sModelName, ".") - 1)

'Check and make a subfolder in same path
If Len(Dir(sTempFolder, vbDirectory)) = 0 Then
MkDir sTempFolder
Else

End If



'call sub to create Zip file
Call ZipFolder(vZipPath & sModelName & ".zip", sTempFolder & "\")

'Macro complete notify message
swModel.Extension.ShowSmartMessage "Succesful", 4000, True, False

End Sub

Sub ZipFolder(vzipFile As Variant, sFolder As String)

Dim PauseTime, Start, Finish, TotalTime As Integer

'Create empty Zip File
If Len(Dir(vzipFile)) > 0 Then Kill vzipFile
Open vzipFile For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1

'Copy the files to the compressed folder
With CreateObject("Shell.Application")
.NameSpace(vzipFile).CopyHere .NameSpace((sFolder)).Items

'Keep script waiting until Compressing is done
On Error Resume Next
Do Until .NameSpace(vzipFile).Items.Count = .NameSpace((sFolder)).Items.Count
PauseTime = 1 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop
Finish = Timer ' Set end time.
Loop
On Error GoTo 0

End With

End Sub