AnsweredAssumed Answered

macro that checks if part/assembly is excluded from BOM

Question asked by Sean Leahy on Jan 24, 2019
Latest reply on Feb 5, 2019 by Sean Leahy

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_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"



    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))


            swModel.ShowNamedView2 "*Isometric", -1


            swModel.ForceRebuild3 False

            swModel.Save2 silent

            swApp.CloseAllDocuments (True)

        End If

        Response = Dir


    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


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



swDrawing.InsertModelAnnotations3 0, 327663, True, True, False, False


swDrawing.SaveAs2 curfilename, 0, False, False


End Sub