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

Outcomes