Running A Batch


Option Explicit 

Public Sub SelectSomeFiles()
Dim fileDialog As Office.fileDialog
Dim varFile As Variant
Dim sFolderPath As String
Dim sFileName As String
Dim objWorksheet As Worksheet
Dim objWorkbook As Workbook
Dim lrowno As Long

    On Error GoTo ErrorHandler
    Set fileDialog = Application.fileDialog(MsoFileDialogType.msoFileDialogFilePicker)
    fileDialog.Title = "Batch Runner"
    fileDialog.InitialFileName = "C:\temp\"
    fileDialog.AllowMultiSelect = True
    fileDialog.Filters.Clear
    fileDialog.Filters.Add "Excel Workbooks", "*.xls*"
    If fileDialog.Show = False Then
        Exit Sub
    End If
    If MsgBox("You have selected " & fileDialog.SelectedItems.Count & " file(s)" & _
              vbCrLf & vbCrLf & "Are you sure ?", _
              VBA.VbMsgBoxStyle.vbYesNo + vbQuestion, _
              "Batch Runner") = VBA.VbMsgBoxResult.vbNo Then
        Exit Sub
    End If
    Set objWorksheet = Workbooks(ThisWorkbook.Name).Sheets("Results")
    Call RemoveAllFiltering(objWorksheet)
    objWorksheet.Cells.ClearContents
    objWorksheet.Cells.Font.Bold = False
    objWorksheet.Select
    objWorksheet.Range("A1").Select
    objWorksheet.Range("A1:B1").Value = Array("File Name", "File Size")
    objWorksheet.Range("A1:B1").Font.Bold = True
    lrowno = 2
    sFolderPath = Left$(fileDialog.SelectedItems(1), InStrRev(fileDialog.SelectedItems(1), "\"))
    sFolderPath = sFolderPath & "__Modified-" & Format(Now(), "yyyy_mmm_dd-hh_mm") & "\"
    Call MkDir(sFolderPath)
    For Each varFile In fileDialog.SelectedItems
        objWorksheet.Range("A" & lrowno).Value = varFile
        objWorksheet.Range("B" & lrowno).Value = VBA.FileLen(varFile) / 1000 & " KB"
        sFileName = Mid$(varFile, InStrRev(varFile, "\") + 1)
        Application.DisplayAlerts = False
        If WbkOpenedSuccessfully(varFile, objWorkbook) = True Then
            Application.DisplayAlerts = True

' do something or check something

            Call objWorkbook.Close(False)
        Else
            objWorksheet.Range("D" & lrowno).Value = "Unable to Open"
        End If
        lrowno = lrowno + 1
        If (lrowno Mod 10 = 0) Then
            Workbooks(ThisWorkbook.Name).Save
        End If
    Next
    objWorksheet.Range("A1").AutoFilter
    objWorksheet.Columns("A:E").EntireColumn.AutoFit
    Call MsgBox("Completed", vbInformation + vbOKOnly)
    Exit Sub
ErrorHandler:
    Call MsgBox(Err.Number & " - " & Err.Description) End Sub

Private Sub RemoveAllFiltering(ByVal objWorksheet As Excel.Worksheet)
    On Error GoTo ErrorHandler
    objWorksheet.ShowAllData
ErrorHandler:
End Sub

Private Function WbkOpenedSuccessfully( _
    ByVal varFile As String, _
    ByRef objWorkbook As Excel.Workbook) As Boolean
    On Error GoTo ErrorHandler
    Set objWorkbook = Workbooks.Open(Filename:=varFile, UpdateLinks:=0)
    WbkOpenedSuccessfully = True
    Exit Function
ErrorHandler:
    WbkOpenedSuccessfully = False
End Function

Private Function WbkSavedSuccessfully( _
    ByVal sFolderPath As String, _
    ByVal sFileName As String, _
    ByVal objWorkbook As Excel.Workbook) As Boolean
    On Error GoTo ErrorHandler
    objWorkbook.SaveAs Filename:=sFolderPath & sFileName
    WbkSavedSuccessfully = True
    Exit Function
ErrorHandler:
    WbkSavedSuccessfully = False
End Function

Private Function PropertyExists( _
    ByVal objWorkbook As Workbook, _
    ByVal sName As String, _
    ByRef docProperty As Office.DocumentProperty) As Boolean
    On Error GoTo ErrorHandler
    Set docProperty = objWorkbook.CustomDocumentProperties.Item(sName)
    PropertyExists = True
    Exit Function
ErrorHandler:
    PropertyExists = False
End Function


© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrev