Attribute VB_Name = "modMain"

' Name:         modMain
' Type:         Module
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/13/2006
' Description:  Application Main module
'		This application will build an Excel spreadsheet of the top and bottom customers based on sales
'		increased/decreased for the current year vs. previous year periods using data from the AS/400.
'		It will than email the spreadsheet as an attachment to selected individuals whose addresses
'		are maintained in a text (.txt) file. The application will be called from the AS/400 using
'		RUNRMTCMD as part of the period-end processing.
' Arguments:    N/A
' Returns:      N/A

Option Explicit

' Module level constants
Private Const m_MOD_NAME = "modMain"

' Name:         Main
' Type:         Sub
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/13/2006
' Description:  Application Start Up procedure
' Arguments:    N/A
' Returns:      N/A

Public Sub Main()

' Error Handler
On Error GoTo Err_Main

' Application initialization
AppInit

' Get sales increased/decreased records
WriteLog m_MOD_NAME & ".Main", "Get Sales records from AS/400"
If GetSales Then
    
    ' Load Excel spreadsheet
    WriteLog m_MOD_NAME & ".Main", "Initialize and Load Excel spreadsheet"
    If InitExl Then
        If LoadExl Then

            ' Save Excel spreadsheet
            WriteLog m_MOD_NAME & ".Main", "Save Excel spreadsheet in HTML format"
            SaveExl
            
            ' Send report
            WriteLog m_MOD_NAME & ".Main", "Sending Excel HTML spreadsheet"
            SendEmail
        End If
    End If
End If

Exit_Main:
    ' Release all objects and terminate
    WriteLog m_MOD_NAME & ".Main", "Application Completed"
    TermApp
    Exit Sub
    
Err_Main:
    WriteLog m_MOD_NAME & ".Main", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_Main

End Sub

' Name:         AppInit
' Type:         Sub
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/13/2006
' Description:  Application Startup Initializations
' Arguments:    N/A
' Returns:      N/A

Public Sub AppInit()

' Error Handler
On Error GoTo Err_AppInit

' Procedure variables
Dim strSQL As String
Dim rsObj As ADODB.Recordset

' Initialize variables
g_strFileLOG = App.Path & "\SalesID.log"
g_strFileXLS = App.Path & "\SalesIncrDecr.xls"
g_strFileHTML = App.Path & "\SalesIncrDecr.htm"
g_strFileADDR = App.Path & "\SalesIncrDecrAddr.txt"

' Generate start up log message
WriteLog m_MOD_NAME & ".Main.AppInit", "Application Start"

' Establish connection to AS/400
If Not SetConnection Then
    End
End If

' Get processing options
strSQL = "SELECT deopt#, desvl FROM xxxxxxxx.f98301 " & _
        " WHERE depid = 'P58024D1' AND devers = 'xxxxxxxx' AND dety = 'O'"

Set rsObj = New ADODB.Recordset
rsObj.CursorLocation = adUseClient
rsObj.CursorType = adOpenForwardOnly
rsObj.ActiveConnection = g_cnxxx
rsObj.Open strSQL

Do While Not rsObj.EOF
    Select Case rsObj.Fields("deopt#")
        Case 1
            g_lngNbrCust = CLng(rsObj.Fields("desvl"))
        Case 2
            If Trim$(rsObj.Fields("desvl")) = "" Then
                g_intCurYear = Year(Now())
            Else
                g_intCurYear = CInt(rsObj.Fields("desvl"))
                If g_intCurYear > 0 And g_intCurYear < 49 Then
                    g_intCurYear = 2000 + g_intCurYear
                Else
                    g_intCurYear = 1900 + g_intCurYear
                End If
            End If
        Case 3
            If Trim$(rsObj.Fields("desvl")) = "" Then
                g_intCurMonth = Month(Now())
            Else
                g_intCurMonth = CInt(rsObj.Fields("desvl"))
            End If
    End Select
    rsObj.MoveNext
Loop

Exit_AppInit:
    Set rsObj = Nothing
    Exit Sub
    
Err_AppInit:
    WriteLog m_MOD_NAME & ".AppInit", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_AppInit

End Sub

' Name:         InitExl
' Type:         Function
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/20/2006
' Description:  Initialize Excel and Build Headings
' Arguments:    N/A
' Returns:      True if successful, False if failed or errors

Public Function InitExl() As Boolean

' Error Handler
On Error GoTo Err_InitExl

' Procedure variables
Dim exlRange As Excel.Range

' Initialize default return value
InitExl = False

' Initialize Excel objects
Set g_exlApp = New Excel.Application
g_exlApp.SheetsInNewWorkbook = 1
g_exlApp.StandardFont = "Arial"
g_exlApp.StandardFontSize = 8

Set g_exlWrkBk = g_exlApp.Workbooks.Add
Set g_exlWrkSht = g_exlWrkBk.Worksheets.Item("Sheet1")

' Page Setup
With g_exlWrkSht.PageSetup
    .Orientation = xlPortrait
    .LeftMargin = 0.25
    .RightMargin = 0.25
    .BottomMargin = 0.5
    .TopMargin = 0.75
    .PrintTitleRows = "$1:$7"
End With

' General formating
Set exlRange = g_exlWrkSht.Range("a1").EntireColumn
exlRange.HorizontalAlignment = xlHAlignCenter

Set exlRange = g_exlWrkSht.Range("b1").EntireColumn
exlRange.HorizontalAlignment = xlHAlignLeft
exlRange.IndentLevel = 1

Set exlRange = g_exlWrkSht.Range("c1").EntireColumn
exlRange.HorizontalAlignment = xlHAlignLeft
exlRange.IndentLevel = 1

Set exlRange = g_exlWrkSht.Range("d1", "g1").EntireColumn
exlRange.HorizontalAlignment = xlHAlignRight
exlRange.NumberFormat = "###,###,###,##0.00"
Set exlRange = g_exlWrkSht.Range("h1").EntireColumn
exlRange.HorizontalAlignment = xlHAlignRight
exlRange.NumberFormat = "#####0.00%"

' Fill headings
Set exlRange = g_exlWrkSht.Range("c1", "c1")
exlRange.Font.Bold = True
exlRange.Font.Size = 14
exlRange.HorizontalAlignment = xlHAlignCenter
exlRange = "xxxxxxxxxxxx, Inc."

Set exlRange = g_exlWrkSht.Range("c2", "c2")
exlRange.Font.Size = 10
exlRange.HorizontalAlignment = xlHAlignCenter
exlRange = "Sales Increase/Decrease"

Set exlRange = g_exlWrkSht.Range("c4", "c4")
exlRange.Font.Size = 10
exlRange.HorizontalAlignment = xlHAlignCenter
exlRange = "As Of " & MonthName(g_intCurMonth) & " Top/Bottom " & CStr(g_lngNbrCust) & " Change"

g_exlWrkSht.Cells(6, 2) = "Customer"
g_exlWrkSht.Cells(6, 4) = "Monthly"
g_exlWrkSht.Cells(6, 5) = (g_intCurYear - 1)
g_exlWrkSht.Range("e6", "e6").NumberFormat = "General"
g_exlWrkSht.Cells(6, 6) = g_intCurYear
g_exlWrkSht.Range("f6", "f6").NumberFormat = "General"
g_exlWrkSht.Cells(6, 8) = "Percent"

g_exlWrkSht.Cells(7, 1) = "Rank"
g_exlWrkSht.Cells(7, 2) = "Number"
g_exlWrkSht.Cells(7, 3) = "Name"
g_exlWrkSht.Cells(7, 4) = "Sales"
g_exlWrkSht.Cells(7, 5) = "Sales"
g_exlWrkSht.Cells(7, 6) = "Sales"
g_exlWrkSht.Cells(7, 7) = "Difference"
g_exlWrkSht.Cells(7, 8) = "Change"

Set exlRange = g_exlWrkSht.Range("a6", "h7")
exlRange.Font.Bold = True
exlRange.Font.Underline = True

' Set Vertical Page Break
g_exlWrkSht.VPageBreaks.Add Before:=g_exlWrkSht.Columns(9)

InitExl = True

Exit_InitExl:
    Exit Function
    
Err_InitExl:
    WriteLog m_MOD_NAME & ".InitExl", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_InitExl

End Function

' Name:         LoadExl
' Type:         Function
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/17/2006
' Description:  Load Excel spreadsheet with sales records
' Arguments:    N/A
' Returns:      N/A

Public Function LoadExl() As Boolean

' Error Handler
On Error GoTo Err_LoadExl

' Procedure variables
Dim lngRecCount As Long
Dim lngRow As Long, lngStartRow As Long
Dim exlRange As Excel.Range
Dim dblTotMnSales As Double
Dim dblTotCrSales As Double
Dim dblTotPrSales As Double
Dim dblTotDiff As Double
Dim bolPrintIncr As Boolean

' Initialize default return value
LoadExl = False

' Get sales record count
lngRecCount = RecCount(g_rsSales)

' Fill spreadsheet detail
lngStartRow = 8
lngRow = lngStartRow - 1
bolPrintIncr = True
g_rsSales.MoveFirst
Do While Not g_rsSales.EOF
    
    ' Only show the requested top/bottom customers
    If CLng(g_rsSales.Fields("qdra01")) <= g_lngNbrCust _
    Or CLng(g_rsSales.Fields("qdra01")) > (lngRecCount - g_lngNbrCust) Then
         lngRow = lngRow + 1
       ' Ranking
        g_exlWrkSht.Cells(lngRow, 1) = CLng(g_rsSales.Fields("qdra01"))
        ' Customer Number
        g_exlWrkSht.Cells(lngRow, 2) = g_rsSales.Fields("qdan8")
        ' Customer Name
        Set exlRange = g_exlWrkSht.Range("c" & CStr(lngRow), "c" & CStr(lngRow))
        exlRange.HorizontalAlignment = xlHAlignLeft
        exlRange.IndentLevel = 1
        exlRange = g_rsSales.Fields("abalph")
        ' Monthly Sales
        g_exlWrkSht.Cells(lngRow, 4) = g_rsSales.Fields("qdas01") / 100
        ' Previous Year Sales
        g_exlWrkSht.Cells(lngRow, 5) = g_rsSales.Fields("qdcmsp") / 100
        ' Current Year Sales
        g_exlWrkSht.Cells(lngRow, 6) = g_rsSales.Fields("qdcmsc") / 100
        ' Sales Difference
        g_exlWrkSht.Cells(lngRow, 7) = g_rsSales.Fields("qdcmsd") / 100
        ' Percent Change
        If g_rsSales.Fields("qdcmsc") <> 0 And g_rsSales.Fields("qdcmsp") = 0 Then
            g_exlWrkSht.Cells(lngRow, 8) = 1
        ElseIf g_rsSales.Fields("qdcmsc") = 0 And g_rsSales.Fields("qdcmsp") <> 0 Then
            g_exlWrkSht.Cells(lngRow, 8) = -1
        Else
            g_exlWrkSht.Cells(lngRow, 8) = g_rsSales.Fields("qdcmsd") / g_rsSales.Fields("qdcmsp")
        End If
        
    End If
        
    ' Fill Top/Bottom summary
    If g_rsSales.Fields("qdra01") = g_lngNbrCust _
    Or g_rsSales.Fields("qdra01") = lngRecCount Then
        ' Add a blank row before totals
        lngRow = lngRow + 1
        
        ' Underline the last detail row
        Set exlRange = g_exlWrkSht.Range("d" & CStr(lngRow), "h" & CStr(lngRow))
        exlRange.Borders(xlEdgeBottom).LineStyle = xlContinuous
        exlRange.Borders(xlEdgeBottom).Weight = xlMedium
        
        ' Increment row for subtotals
        lngRow = lngRow + 1
        
        ' Sub-Total Description
        Set exlRange = g_exlWrkSht.Range("c" & CStr(lngRow), "c" & CStr(lngRow))
        exlRange.HorizontalAlignment = xlHAlignLeft
        exlRange.IndentLevel = 1
        exlRange = "Totals of " & _
                    IIf((g_rsSales.Fields("qdra01") = g_lngNbrCust), "Top ", "Bottom ") & _
                    CStr(g_lngNbrCust) & " Customers:"

        ' Sub-Total Monthly Sales
        g_exlWrkSht.Range("d" & CStr(lngRow), "d" & CStr(CStr(lngRow))).Formula = _
                        "=SUM(d" & CStr(lngStartRow) & ":d" & CStr(lngRow - 1) & ")"
        ' Sub-Total Previous Year Sales
        g_exlWrkSht.Range("e" & CStr(lngRow), "e" & CStr(CStr(lngRow))).Formula = _
                        "=SUM(e" & CStr(lngStartRow) & ":e" & CStr(lngRow - 1) & ")"
        ' Sub-Total Current Year Sales
        g_exlWrkSht.Range("f" & CStr(lngRow), "f" & CStr(CStr(lngRow))).Formula = _
                        "=SUM(f" & CStr(lngStartRow) & ":f" & CStr(lngRow - 1) & ")"
        ' Sub-Total Sales Difference
        g_exlWrkSht.Range("g" & CStr(lngRow), "g" & CStr(CStr(lngRow))).Formula = _
                        "=SUM(g" & CStr(lngStartRow) & ":g" & CStr(lngRow - 1) & ")"
        g_exlWrkSht.Cells(lngRow, 8) = g_exlWrkSht.Cells(lngRow, 7) / g_exlWrkSht.Cells(lngRow, 5)

    End If
    
    ' Fill totals for all increased/decreased sales
    If (g_rsSales.Fields("qdcmsd") < 0) And bolPrintIncr _
    Or CLng(g_rsSales.Fields("qdra01")) = lngRecCount Then
        
        ' Underline last row before group totals
        Set exlRange = g_exlWrkSht.Range("d" & CStr(lngRow), "h" & CStr(lngRow))
        exlRange.Borders(xlEdgeBottom).LineStyle = xlContinuous
        exlRange.Borders(xlEdgeBottom).Weight = xlMedium

        ' Increment row for group totals
        lngRow = lngRow + 1
        
        ' Group total description
        Set exlRange = g_exlWrkSht.Range("c" & CStr(lngRow), "c" & CStr(lngRow))
        exlRange.HorizontalAlignment = xlHAlignLeft
        exlRange.IndentLevel = 1
        exlRange = "Totals For All " & _
                    IIf((g_rsSales.Fields("qdra01") < lngRecCount), _
                    "Increased Sales:", "Decreased Sales:")

        ' For the last group totals add in the detail amounts
        If CLng(g_rsSales.Fields("qdra01")) = lngRecCount Then
            dblTotMnSales = dblTotMnSales + (g_rsSales.Fields("qdas01") / 100)
            dblTotPrSales = dblTotPrSales + (g_rsSales.Fields("qdcmsp") / 100)
            dblTotCrSales = dblTotCrSales + (g_rsSales.Fields("qdcmsc") / 100)
            dblTotDiff = dblTotDiff + (g_rsSales.Fields("qdcmsd") / 100)
        End If
        
        ' Total Monthly Sales - Increased/Decreased Group
        g_exlWrkSht.Cells(lngRow, 4) = dblTotMnSales
        ' Total Previous Year Sales - Increased/Decreased Group
        g_exlWrkSht.Cells(lngRow, 5) = dblTotPrSales
        ' Total Current Year Sales - Increased/Decreased Group
        g_exlWrkSht.Cells(lngRow, 6) = dblTotCrSales
        ' Total Sales Difference - IncreasedDecreased Group
        g_exlWrkSht.Cells(lngRow, 7) = dblTotDiff
        ' Percent Change - Increased/Decreased Group
        g_exlWrkSht.Cells(lngRow, 8) = g_exlWrkSht.Cells(lngRow, 7) / g_exlWrkSht.Cells(lngRow, 5)
            
        
        ' Clear Totals and set start row
        dblTotMnSales = 0
        dblTotPrSales = 0
        dblTotCrSales = 0
        dblTotDiff = 0
        lngRow = lngRow + 1
        lngStartRow = lngRow
        bolPrintIncr = False
        
    End If
    
    ' Accummulate Increase/Decrease Totals
    dblTotMnSales = dblTotMnSales + (g_rsSales.Fields("qdas01") / 100)
    dblTotPrSales = dblTotPrSales + (g_rsSales.Fields("qdcmsp") / 100)
    dblTotCrSales = dblTotCrSales + (g_rsSales.Fields("qdcmsc") / 100)
    dblTotDiff = dblTotDiff + (g_rsSales.Fields("qdcmsd") / 100)
    
    g_rsSales.MoveNext
Loop

' Perform final formating
g_exlWrkSht.Range("a1", "h" & CStr(lngRow)).Select
With g_exlWrkSht.Columns
    .AutoFit
    .WrapText = True
    .Orientation = 0
    .ShrinkToFit = False
    .AddIndent = False
    .MergeCells = False
    .BorderAround xlContinuous, xlThin
End With

g_exlWrkSht.Range("a8", "h" & CStr(lngRow)).Select
With g_exlWrkSht.Columns
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).Weight = xlThin
    .Borders(xlInsideVertical).LineStyle = xlContinuous
    .Borders(xlInsideVertical).Weight = xlThin
End With

Set exlRange = g_exlWrkSht.Range("a1", "h5")
With exlRange
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
End With

Set exlRange = g_exlWrkSht.Range("a8").EntireRow
g_exlWrkBk.Windows.Item(1).FreezePanes = True
g_exlWrkSht.Range("a1", "a1").Activate

g_exlWrkSht.Range("a6", "h7").Borders(xlInsideHorizontal).LineStyle = xlNone

' To print preview, activate following two lines
'g_exlApp.Visible = True
'g_exlWrkSht.PrintPreview

LoadExl = True

Exit_LoadExl:
    Set exlRange = Nothing
    Exit Function
    
Err_LoadExl:
    WriteLog m_MOD_NAME & ".LoadExl", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_LoadExl

End Function

' Name:         GetSales
' Type:         Function
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/17/2006
' Description:  Get the Sales Increased/Decreased recordset
' Arguments:    N/A
' Returns:      True    - Recordset opened successfully
'               False   - Open failed

Public Function GetSales() As Boolean

' Error Handler
On Error GoTo Err_GetSales

' Procedure variables
Dim strSQL As String

' Initialize default return value
GetSales = False

' Build SQL string
strSQL = "SELECT qdan8, qdyrm, qdcmsc, qdcmsp, qdcmsd, qdra01, qdas01, abalph " & _
        " FROM xxxxxxxx.f58024df " & _
        " JOIN xxxxxxxx.f0101 ON qdan8 = aban8 " & _
        " ORDER BY qdra01"

' Load sales records
Set g_rsSales = New ADODB.Recordset
g_rsSales.CursorLocation = adUseClient
g_rsSales.CursorType = adOpenKeyset
g_rsSales.ActiveConnection = g_cnxxx
g_rsSales.Open strSQL

If Not g_rsSales.BOF Then
    GetSales = True
Else
    WriteLog m_MOD_NAME & ".GetSales .OpenRecordset", "Recordset load failed"
End If

Exit_GetSales:
    Exit Function
    
Err_GetSales:
    WriteLog m_MOD_NAME & ".GetSales", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_GetSales

End Function

' Name:         SaveExl
' Type:         Sub
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/18/2006
' Description:  Save Excel spreadsheet in html format
' Arguments:    N/A
' Returns:      N/A

Public Sub SaveExl()

' Error Handler
On Error GoTo Err_SaveExl

' Save current spreadsheet
g_exlApp.DisplayAlerts = False
g_exlWrkBk.SaveAs g_strFileXLS, xlNormal
'g_exlWrkBk.SaveAs g_strFileHTML, xlHtml
g_exlApp.DisplayAlerts = True

Exit_SaveExl:
    Exit Sub
    
Err_SaveExl:
    WriteLog m_MOD_NAME & ".SaveExl", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_SaveExl

End Sub

' Name:         SendEmail
' Type:         Sub
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/18/2006
' Description:  Email the Sales Increased/Decreased report
' Arguments:    N/A
' Returns:      N/A

Public Sub SendEmail()

' Error Handler
On Error GoTo Err_SendEmail

' Procedure variables
Dim oulApp As Outlook.Application
Dim oulMail As Outlook.MailItem

' Send email
Set oulApp = New Outlook.Application
Set oulMail = oulApp.CreateItem(olMailItem)
With oulMail
    .To = GetEmailAddr()
    .Subject = "Sales Increased/Decreased Report"
    .Attachments.Add g_strFileXLS
    .Send
End With

Exit_SendEmail:
    Set oulMail = Nothing
    Set oulApp = Nothing
    Exit Sub
    
Err_SendEmail:
    WriteLog m_MOD_NAME & ".SendEmail", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_SendEmail

End Sub

' Name:         TermApp
' Type:         Sub
' Author :      Jim Mabee - JBM Programming Services
' Created :     04/18/2006
' Description:  Release all objects and terminate application
' Arguments:    N/A
' Returns:      N/A

Public Sub TermApp()

' Error Handler
On Error GoTo Err_TermApp

g_exlApp.Workbooks(1).Close SaveChanges:=False
g_exlApp.Quit

Set g_exlWrkSht = Nothing
Set g_exlWrkBk = Nothing
Set g_exlApp = Nothing
Set g_rsSales = Nothing
Set g_cnxxx = Nothing

' Delete files
On Error Resume Next
Kill g_strFileXLS
Kill g_strFileHTML

End

Exit_TermApp:
    Exit Sub
    
Err_TermApp:
    WriteLog m_MOD_NAME & ".TermApp", Err.Source & " " & Err.Number & " " & Err.Description
    Resume Exit_TermApp

End Sub