Macro to batch process a bunch of files in a directory 2

[dufus]

Hi folks,

I'm chasing a macro to batch process the changing of the density in a whole bunch of part files.

I was thinking it would be as easy as recording a macro and getting task scheduler to batch it for me but it doesn't seem to give the option to apply it to any files or directories .

The trick, it would appear, is to parse through a directory pulling out all the *.sldprt files and modifying them as necessary. I lack the ability to write a macro to do this so I was wondering if anybody seen or got anything that could do this.

Cheers,
Dufus

 

[CorBlimeyLimey]

Take a look at the macros at

http://www.lennyworks.com/solidworks/default.asp?ID=20

There may be one you can use directly or modify to suit your needs.

 

[TheTick]

<

http://www.esoxrepublic.com/freeware/>

Density Manager macro and addin can change multiple parts within an assembly.

Honesty may be the best policy, but insanity is a better defense.

http://www.EsoxRepublic.com

-SolidWorks API VB programming help

 

[dogarila]

Maybe this wil help:
Module 1

Option Explicit

Dim swApp As Object
Dim swPart As Object
Dim swDwg As Object
Dim strNewLine3 As String
Const swDocDRAWING = 3
Const swDocPART = 1
Const swDocASSEMBLY = 2
Const swOpenDocOptions_Silent = &H1
Dim retval As Boolean, retval1 As Long, lngOha As Long
Dim sMask As String


Sub Main()
    Dim sPath As String
    Dim sFileSW As String
    Dim sFileDWG As String
    Dim sFileDXF As String
    Dim sFilePRN As String
    Dim sFileTitle As String
    Dim iParts As Integer, iAssy As Integer, iDrw As Integer
    Dim sMsg As String

 sPath = BrowseForFolder(0, "Please select a Server folder.")
If sPath = "" Then
    Exit Sub
Else
    sPath = sPath & "\"
End If
 
sMsg = "Enter drawings mask (if applicable). Use '*' for all."
sMask = InputBox(sMsg, "Drawings Mask", "*")
If sMask = "" Then sMask = "*"
 
    Set swApp = CreateObject("SldWorks.Application")
    iParts = 0
    iAssy = 0
    iDrw = 0
    
    'process parts
    sFileSW = Dir(sPath & sMask & "*.sldprt")

    Do While sFileSW <> ""
        'Open file
       Set swPart = swApp.OpenDoc2(sPath & sFileSW, swDocPART, False, False, True, lngOha)
        
        If swPart Is Nothing Then
            Call MsgBox("Unable to open document!", vbExclamation, "Line3")  ' Display error message
            End                    ' If no model currently loaded, then exit
        End If
         'counter
        iParts = iParts + 1
        'do part processing
        'save file
        retval1 = swPart.Save2(True)
        'Close File
        sFileTitle = swPart.GetTitle
        swApp.CloseDoc sFileTitle
        'Next File
        sFileSW = Dir
    Loop
    
   
    'process assemblies
    sFileSW = Dir(sPath & "*.sldasm")

    Do While sFileSW <> ""
        'Open file
        Set swPart = swApp.OpenDoc2(sPath & sFileSW, swDocASSEMBLY, False, False, True, lngOha)
        
        If swPart Is Nothing Then
            Call MsgBox("Unable to open document!", vbExclamation, "Line3")  ' Display error message
            End                    ' If no model currently loaded, then exit
        End If

        'counter
        iAssy = iAssy + 1
        'do assembly processing
        'save file
        retval1 = swPart.Save2(True)
        'Close File
        sFileTitle = swPart.GetTitle
        swApp.CloseDoc sFileTitle
        'Next File
        sFileSW = Dir
    Loop
    
    'process drawings
     sFileSW = Dir(sPath & "*.slddrw")

    Do While sFileSW <> ""
        'Open file
       Set swPart = swApp.OpenDoc2(sPath & sFileSW, swDocDRAWING, False, False, True, lngOha)
        
        If swPart Is Nothing Then
            Call MsgBox("Unable to open document!", vbExclamation, "Line3")  ' Display error message
            End                    ' If no model currently loaded, then exit
        End If

        'counter
        iDrw = iDrw + 1
        'do drawing processing
        'save file
        retval1 = swPart.Save2(True)
        'Close File
        sFileTitle = swPart.GetTitle
        swApp.CloseDoc sFileTitle
        'Next File
        sFileSW = Dir
    Loop
    
    swApp.SendMsgToUser Str(iParts) & " parts, " & Str(iAssy) & "assemblies & " & Str(iDrw) & " drawings changed in folder" & vbCrLf & _
                        sPath & " !"
                        
End Sub

Module 2

Option Explicit

Public Type BrowseInfo
     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
      
    'declare variables to be used
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

    'initialise variables
     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With

    'Call the browse for folder API
     lpIDList = SHBrowseForFolder(udtBI)
      
    'get the resulting string path
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If

    'If cancel was pressed, sPath = ""
     BrowseForFolder = sPath

End Function

Module 2 is from the Tick or handleman

 

[dogarila]

Module 2 is from the Tick. If you use it give him a star.

 

[dufus]

Thanks for all the input guys.

I'll do some cutting and pasting and see if I can get it to work. A star for you Dogarila .