Excel VBA

Mail File from Excel

Option Explicit

'+---------------------------------------------------------------+
'|   Created 04/17/2003 by Alan Barasch (314)xxx-xxxx|
'|   Take information from GL Invoices text file and make        |
'|   Excel files to automatically email to Branch Administrators |
'|            Customer:  Janet Crabtree                          |
'+---------------------------------------------------------------+
Public Branch As String, TopStuff As Long
Public x        As Long
Public G        As Long, NameConv As String, Z As String
Public LastRow As Long, ExpFileName As String
Public BrRow    As Long
Public BranchAdmin As String


Sub TrafficCop()
    TopStuff = 0
    usrAPinvoices.txtInputFileName = "\\stlds1\shared\excel\jc\AP Report.txt"
    usrAPinvoices.Show
    Application.ScreenUpdating = True
    Unload usrAPinvoices
    MsgBox "Done making " & TopStuff & " Invoice Spreadsheets", vbOKOnly, "Progress"
End Sub

Next secion opens a text file for import

Sub GetTextData()
Application.ScreenUpdating = False
Close #1
TopStuff = TopStuff + 1
BrRow = 3
    Open ThisWorkbook.Path & "\AP Report.TXT" For Input Access Read As #1
    For x = 1 To 5
        Line Input #1, Z
        If x = 4 Then
            With Workbooks(ExpFileName).Sheets("Sheet1")
                .Cells(1, 3) = Mid(Z, 16, 5)
                .Cells(1, 4) = "to"
                .Cells(1, 5) = Mid(Z, 31, 5)
            End With
        End If
                        Debug.Print Cells(1, 3) & "  " & Mid(Z, 16, 2)
        If x = 5 Then
            With Workbooks(ExpFileName).Sheets("Sheet1")
                .Cells(1, 3) = Cells(1, 3) & Mid(Z, 16, 2)

                .Cells(1, 5) = Cells(1, 5) & Mid(Z, 31, 2)
            End With
        End If
    Next
    Do While Not EOF(1)
    
    Line Input #1, Z
        If Left(Z, 3) = Branch Then
            With Workbooks(ExpFileName).Sheets("Sheet1")
                .Cells(BrRow, 1) = Left(Z, 12)
                .Cells(BrRow, 2) = Mid(Z, 13, 11)
                .Cells(BrRow, 3) = Mid(Z, 28, 10)
                .Cells(BrRow, 4) = Mid(Z, 39, 10)
                .Cells(BrRow, 5) = Mid(Z, 50, 15)
                .Cells(BrRow, 6) = Mid(Z, 67, 30)
                .Cells(BrRow, 7) = Right(Z, 14)
            End With
            BrRow = BrRow + 1
        End If
            
    Loop
    Close #1
End Sub

Make the Excel file to mail

Sub MakeSeparates()
    'Makes separate files to send to each regional
    Sheets("Front").Activate
    LastRow = Application.CountA(ActiveSheet.Range("H:H"))
    For G = 2 To LastRow
        Branch = Cells(G, 8).Value
        BranchAdmin = Cells(G, 9).Text
        ExpFileName = Branch & Application.Text(Now(), "yyyymmdd") & "APinv.xls"
        Workbooks.Add
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ExpFileName, _
            FileFormat:=xlNormal    'Save without asking
        Application.DisplayAlerts = True
        Workbooks(ExpFileName).Activate
        With Workbooks(ExpFileName).Sheets("Sheet1")
            .Cells(2, 1) = "Department"
            .Cells(2, 2) = "Acct Number"
            .Cells(2, 3) = "Invoice Date"
            .Cells(2, 4) = "Trans Date"
            .Cells(2, 5) = "Invoice Number"
            .Cells(2, 6) = "Vendor Name"
            .Cells(2, 7) = "Amount"
            .Cells(1, 1) = "AP Invoices by GL Account"
        End With
        Range("A2:G2").Select
        With Selection
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlTop
        End With
        GetTextData
        Range("A2:G2").Select
        With Selection
            .EntireColumn.AutoFit
        End With
        MailNow
        ThisWorkbook.Sheets("Front").Activate
    Next
End Sub

Perform the mailing. Outlook may report a problem

Sub MailNow()
    Dim objSht      As Object
    Dim objCell     As Object
    Dim mArray, J, Counter
    Dim Ranger      As String
    Dim EndRow      As Long
    Dim NamesArray  As Variant, mMsg, Alpha
    Set objSht = ThisWorkbook.Sheets("Front")
    ThisWorkbook.Activate
    objSht.Activate
    EndRow = Application.CountA(ActiveSheet.Range("H:H"))
    mArray = Range(Cells(2, 9), Cells(EndRow, 9)).Value
    J = objSht.UsedRange.Rows.Count
    ReDim NamesArray(J, 12)
    Counter = 1
    While Counter <= UBound(mArray)
        Counter = Counter + 1
    Wend
    With usrAPinvoices
        If usrAPinvoices.optEmailRpts = True Then
            Application.DisplayAlerts = False
            'mailing routine
            Workbooks(ExpFileName).Activate
            mMsg = "This Invoice file created on " & _
                Application.Text(Now(), "dd mmm yyyy HH:mm") _
                & ". Advise Ms. Crabtree immediately with errors."
            If ActiveWorkbook.HasRoutingSlip = False Then
                ActiveWorkbook.HasRoutingSlip = True
            End If
            With ActiveWorkbook.RoutingSlip
                .Recipients = BranchAdmin
                .Subject = Branch & " AP Invoices"
                .Message = mMsg
                .Delivery = xlAllAtOnce
                .ReturnWhenDone = False
                .TrackStatus = True
            End With
           Application.DisplayAlerts = True
        Else
            'don't mail
        End If
    End With
End Sub