Takes information from an Access DB and outputs a Word document that displays the information visually using ASCII characters and shading.

Word Report from Access DB

Private Sub Roadmap_Click()

    On Error GoTo Err_Handler

    Dim db As Database, rs As Recordset
    Dim wdObj As Word.Application
    Dim wdDoc As Word.Document
    Dim lgNumRows As Long
    Dim iRow As Integer
    Dim iColumn As Integer
    Dim KStartDate As Date
    Dim KEndDate As Date
    Dim intCounter As Integer
    Dim strArrow As String
    Dim lngLeftCell As Long
    Dim lngRightCell As Long
    Dim PORThisRecord As String
    Dim PORNextRecord As String
    Dim wdRange As Word.Range

    ' Open up a recordset on the Employees table.
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qryRoadmap", dbOpenDynaset)
    
    
    ' Open up an instance of Word
    Set wdObj = New Word.Application
    wdObj.Application.Visible = True
    Set wdDoc = New Word.Document
    
    ' Prepare the recordset
    rs.MoveLast
    lgNumRows = rs.RecordCount
    
    ' Prepare the Word Document - Change to landscape and legal paper
    wdDoc.PageSetup.PaperSize = wdPaperLegal
    wdDoc.PageSetup.Orientation = wdOrientLandscape
    
    'Insert and Format Title
    wdDoc.Range.InsertBefore "Contract Roadmap Report as of " & Now() & vbCrLf
    
    Set wdRange = wdDoc.Paragraphs(wdDoc.Paragraphs.Count - 1).Range
        wdRange.Font.Bold = True
        wdRange.Font.Shadow = True
        wdRange.Font.Size = 14
    
    'Add a table
    Set wdRange = wdDoc.Content
    wdRange.Collapse (wdCollapseEnd)
    With wdDoc.Tables.Add(wdRange, lgNumRows + 1, 15)
        .Cell(1, 1).Range.InsertAfter "Office"
        .Cell(1, 2).Range.InsertAfter "Program"
        .Cell(1, 3).Range.InsertAfter "Contract"
        .Cell(1, 4).Range.InsertAfter "Company Name"
        .Cell(1, 5).Range.InsertAfter "Info"
        .Cell(1, 6).Range.InsertAfter "FY08"
        .Cell(1, 7).Range.InsertAfter "FY09"
        .Cell(1, 8).Range.InsertAfter "FY10"
        .Cell(1, 9).Range.InsertAfter "FY11"
        .Cell(1, 10).Range.InsertAfter "FY12"
        .Cell(1, 11).Range.InsertAfter "FY13"
        .Cell(1, 12).Range.InsertAfter "FY14"
        .Cell(1, 13).Range.InsertAfter "FY15"
        .Cell(1, 14).Range.InsertAfter "FY16"
        .Cell(1, 15).Range.InsertAfter "FY17"
    End With
    
    rs.MoveFirst

    With wdDoc.Tables(1)
        While Not rs.EOF
            .Cell(rs.AbsolutePosition + 2, 1).Range.InsertAfter CStr(rs.Fields("tblOwner.Office").Value)
            .Cell(rs.AbsolutePosition + 2, 2).Range.InsertAfter CStr(rs.Fields("tblOwner.Program").Value)
            .Cell(rs.AbsolutePosition + 2, 3).Range.InsertAfter CStr(rs.Fields("tblContracts.KNumber").Value)
            .Cell(rs.AbsolutePosition + 2, 4).Range.InsertAfter CStr(rs.Fields("tblContracts.KName").Value) & vbCrLf _
                & CStr(rs.Fields("tblCompanies.CompanyName").Value & vbNullString)
            .Cell(rs.AbsolutePosition + 2, 5).Range.InsertAfter "PoP Base: " & CStr(rs.Fields("tblContracts.PoPBaseEstStartDate").Value & vbNullString) _
                & " - " & CStr(rs.Fields("tblContracts.PoPBaseEstEndDate").Value & vbNullString) & vbCrLf & "PoP Option(s): " & _
                CStr(rs.Fields("tblContracts.PoPOptionEstStartDate").Value & vbNullString) & " - " & _
                CStr(rs.Fields("tblContracts.PoPOptionEstEndDate").Value & vbNullString)
            
            'Converts from GFY to CY
            If IsNull(rs.Fields("tblContracts.PoPBaseEstStartDate").Value) Then
                'Need a fake date to avoid a Null error
                KStartDate = CDate("30/09/1900")
            Else
                KStartDate = DateAdd("m", 3, rs.Fields("tblContracts.PoPBaseEstStartDate").Value)
            End If
            If IsNull(rs.Fields("tblContracts.PoPOptionEstEndDate").Value) Then
                If IsNull(rs.Fields("tblContracts.PoPBaseEstEndDate").Value) Then
                    'More Null fixes
                    KEndDate = CDate("30/09/2200")
                Else
                    KEndDate = DateAdd("m", 3, rs.Fields("tblContracts.PoPBaseEstEndDate").Value)
                End If
            Else
                KEndDate = DateAdd("m", 3, rs.Fields("tblContracts.PoPOptionEstEndDate").Value)
            End If
            
            'Keep the start date in range
            If CLng(Format(KStartDate, "yy")) - 2 < 6 Then
                lngLeftCell = 6
            Else
                lngLeftCell = CLng(Format(KStartDate, "yy")) - 2
            End If
            
            'Keep the end date in range
            If CLng(Format(KEndDate, "yy")) - 2 > 15 Then
                lngRightCell = 15
            Else
                lngRightCell = CLng(Format(KEndDate, "yy")) - 2
            End If
                
            'Skip if no start date
            If KStartDate = CDate("30/09/1900") Or lngLeftCell > 15 Then
                rs.MoveNext
            Else
                If lngLeftCell <> lngRightCell Then
                    'Merge cells across PoP if crossing FYs
                    .Cell(rs.AbsolutePosition + 2, lngLeftCell).Merge .Cell(rs.AbsolutePosition + 2, lngRightCell)
                End If
                'Reset arrow string
                strArrow = ""
                'Create arrow
                For intCounter = 0 To (CInt(lngRightCell - lngLeftCell))
                    strArrow = strArrow & "==="
                Next intCounter
                'Insert and format arrow
                With .Cell(rs.AbsolutePosition + 2, lngLeftCell).Range
                    .InsertAfter strArrow & ">"
                    .Font.Bold = True
                    'Change the color for a sole source
                    If rs.Fields("tblContracts.Competition").Value = "Sole-Source Award" Then
                        .Font.ColorIndex = wdRed
                    Else
                        .Font.ColorIndex = wdGreen
                    End If
                    .Font.Size = 14
                    .Font.Shadow = True
                    .ParagraphFormat.Space1
                    .ParagraphFormat.SpaceAfter = 0
                    .ParagraphFormat.Alignment = wdAlignParagraphCenter
                    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
                    .Cells.Shading.BackgroundPatternColor = wdColorGray10
                End With
                    'Check this records Program against the next record's Program to determine if this is the last in the Program's series
                    PORThisRecord = rs.Fields("tblOwner.Program").Value
                    'Check whether this contract is the last one in the recordset
                    If rs.AbsolutePosition + 1 <> rs.RecordCount Then
                        rs.MoveNext
                        PORNextRecord = rs.Fields("tblOwner.Program").Value
                        rs.MovePrevious
                    Else
                        PORNextRecord = vbNullString
                    End If
                    If PORThisRecord <> PORNextRecord Then
                        'Check whether this contract is at the end of the FYs
                        If lngRightCell <> 15 Then
                            'Add the end of Program's life marker
                            With .Cell(rs.AbsolutePosition + 2, lngLeftCell + 1).Range
                                .InsertAfter "+"
                                .Font.Bold = True
                                .Font.Size = 14
                                .Font.Shadow = True
                                .ParagraphFormat.Space1
                                .ParagraphFormat.SpaceAfter = 0
                                .ParagraphFormat.Alignment = wdAlignParagraphCenter
                                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
                                .Cells.Shading.BackgroundPatternColor = wdColorRose
                            End With
                    End If
                End If
                rs.MoveNext
            End If
                        
        Wend
    End With
    
    wdDoc.Tables(1).AutoFitBehavior (wdAutoFitContent)
    wdDoc.Tables(1).Borders.InsideLineStyle = wdLineStyleSingle
    wdDoc.Tables(1).Borders.InsideColor = wdColorBlack
    wdDoc.Tables(1).Borders.OutsideLineStyle = wdLineStyleSingle
    wdDoc.Tables(1).Borders.OutsideColor = wdColorBlack
    wdDoc.Tables(1).Rows.Alignment = wdAlignRowCenter
    wdDoc.Tables(1).Rows.AllowBreakAcrossPages = False
    
    For iColumn = 1 To wdDoc.Tables(1).Columns.Count
        With wdDoc.Tables(1).Cell(1, iColumn).Range
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            .ParagraphFormat.SpaceAfter = 0
            .ParagraphFormat.Space1
        End With
    Next iColumn
    
    For iRow = 2 To wdDoc.Tables(1).Rows.Count
        For iColumn = 1 To 5
            With wdDoc.Tables(1).Cell(iRow, iColumn).Range
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
                .ParagraphFormat.SpaceAfter = 0
                .ParagraphFormat.Space1
            End With
        Next iColumn
    Next iRow
    
    wdDoc.Range.InsertAfter vbCrLf & "Legend" & vbCrLf & "======> denotes contract length of a competitively-awarded contract" _
        & vbCrLf & "======> denotes contract length of a sole-source contract" & vbCrLf & "+ denotes the end of a Program's planned contracts.  " _
        & "The program is either delegating sustainment support to Echelon III or needs to plan a new contract."
    
    wdDoc.Paragraphs(wdDoc.Paragraphs.Count - 3).Range.Font.Bold = True
    wdDoc.Paragraphs(wdDoc.Paragraphs.Count - 3).Range.Font.Underline = wdUnderlineDouble
    
    Set wdRange = wdDoc.Paragraphs(wdDoc.Paragraphs.Count - 2).Range
        wdRange.Collapse wdCollapseStart
        wdRange.MoveEnd wdCharacter, 7
        wdRange.Font.Bold = True
        wdRange.Font.Shadow = True
        wdRange.Font.Size = 14
        wdRange.Font.ColorIndex = wdGreen
        
    Set wdRange = wdDoc.Paragraphs(wdDoc.Paragraphs.Count - 1).Range
        wdRange.Collapse wdCollapseStart
        wdRange.MoveEnd wdCharacter, 7
        wdRange.Font.Bold = True
        wdRange.Font.Shadow = True
        wdRange.Font.Size = 14
        wdRange.Font.ColorIndex = wdRed
        
    Set wdRange = wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
        wdRange.Collapse wdCollapseStart
        wdRange.MoveEnd wdCharacter, 1
        wdRange.Font.Bold = True
        wdRange.Font.Shadow = True
        wdRange.Font.Size = 14
        
    'wdDoc.Words.Last.Bold = True
    'wdDoc.Words.Last.Underline = wdUnderlineDouble
    
    wdDoc.Activate

endit:
    
    Exit Sub
    
Err_Handler:
    
    MsgBox "An unexpected error has been detected" & vbCrLf & "Description is: " & Err.Description & vbCrLf & "Error number is: " & Err.Number
    
'   Debug.Print Err.Number
    
    Resume endit

End Sub