i have a macro that automatically creates a drawing for every part and assembly in a selected folder. i would like help to modify this so that it skips over any part or assembly that has the exclude from BOM checked. below is the macro script
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 swDrawing As DrawingDoc
Dim filename As String
Dim ext As String
Dim longerrors As Long, longwarnings As Long
Dim swApp As SldWorks.SldWorks
Dim swSktManager As SldWorks.SketchManager
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swSheet As SldWorks.Sheet
Dim sPath As String
Dim Path As String
Dim swFilename As String
Dim nErrors As Long
Dim nWarnings As Long
Dim Response As String
Dim DocName As String
Dim bret As Boolean
Dim swDocTypeLong As Long
Dim vConfs As Variant
Dim vPropNames As Variant
Dim i As Integer
Dim j As Integer
Dim fso As New Scripting.FileSystemObject
Dim MYext As String
Dim swCustPropMgr As SldWorks.CustomPropertyManager
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 main()
Set swApp = Application.SldWorks
Path = BrowseFolder()
If Path = "" Then
MsgBox "Please select the path and try again"
End
Else
Path = Path & "\"
End If
BatchFolder Path, ".SLDPRT", ".SLDASM", True
MsgBox "DONE"
End Sub
Sub BatchFolder(folder As String, ext As String, ext2 As String, silent As Boolean)
If Right(folder, 1) <> "\" Then folder = folder & "\"
ChDir (folder)
Response = Dir(folder)
Do Until Response = ""
swFilename = folder & Response
Debug.Print swFilename
MYext = Right(UCase\$(Response), 7)
If MYext = ext Or MYext = ext2 Then 'this is a file type we want, process it
swDocTypeLong = Switch(MYext = ".SLDPRT", swDocPART, MYext = ".SLDDRW", swDocDRAWING, MYext = ".SLDASM", swDocASSEMBLY, True, -1)
Set swModel = swApp.OpenDoc6(swFilename, swDocTypeLong, swOpenDocOptions_Silent, "", nErrors, nWarnings)
Set swModelDocExt = swModel.Extension
vConfs = swModel.GetConfigurationNames
For i = 0 To UBound(vConfs)
Debug.Print " Main: " & vConfs(i)
If vConfs(i) <> "Custom" Then ClearCustPrps (vConfs(i))
Next
swModel.ShowNamedView2 "*Isometric", -1
swModel.ViewZoomtofit2
swModel.ForceRebuild3 False
swModel.Save2 silent
swApp.CloseAllDocuments (True)
End If
Response = Dir
Loop
Dim myFolder As folder
Dim mySub As folder
Set myFolder = fso.GetFolder(folder)
For Each mySub In myFolder.SubFolders
BatchFolder mySub.Path, ext, ext2, silent
Next
End Sub
Sub ClearCustPrps(conf As String)
Set fso = CreateObject("Scripting.FileSystemObject")
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then Exit Sub
filename = swModel.GetPathName
ext = UCase(Right(filename, 6))
If ext <> "SLDPRT" And ext <> "SLDASM" Then Exit Sub
Dim curfilename As String
curfilename = Left(filename, Len(filename) - 7) & ".SLDDRW"
If fso.FileExists(curfilename) Then
If MsgBox(curfilename & " already exists. Overwrite?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
End If
Dim template As String
template = swApp.GetUserPreferenceStringValue(swDefaultTemplateDrawing)
Set swDrawing = swApp.NewDocument(template, 0, 0, 0)
If swDrawing Is Nothing Then
MsgBox "Failed to create drawing"
Exit Sub
End If
If (ext = "SLDPRT") Then
swApp.OpenDoc6 filename, swDocPART, swOpenDocOptions_ReadOnly, "", longerrors, longwarnings
Else: swApp.OpenDoc6 filename, swDocASSEMBLY, swOpenDocOptions_ReadOnly, "", longerrors, longwarnings
End If
swDrawing.Create3rdAngleViews2 filename
Dim cursheet As Sheet
Dim sheetwidth As Double, sheetheight As Double
Set cursheet = swDrawing.GetCurrentSheet
cursheet.GetSize sheetwidth, sheetheight
Dim view As view
Dim vOutline As Variant, vPosition As Variant
Dim viewWidth As Double, viewHeight As Double
Set view = swDrawing.CreateDrawViewFromModelView3(filename, "*Isometric", sheetwidth, sheetheight, 0)
vOutline = view.GetOutline
vPosition = view.Position
viewWidth = vOutline(2) - vOutline(0)
viewHeight = vOutline(3) - vOutline(1)
vPosition(0) = vPosition(0) - viewWidth
vPosition(1) = vPosition(1) - viewHeight
view.Position = vPosition
Dim v As view
Set v = swDrawing.GetFirstView ' Sheet
Set v = v.GetNextView ' First view
swDrawing.ClearSelection2 True
While Not v Is Nothing
If v.Name <> view.Name Then swDrawing.Extension.SelectByID2 v.Name, "DRAWINGVIEW", 0, 0, 0, True, -1, Nothing, 0
Set v = v.GetNextView
Wend
swDrawing.InsertModelAnnotations3 0, 327663, True, True, False, False
swDrawing.SaveAs2 curfilename, 0, False, False
End Sub
SolidworksApi/macros