Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Takes information from an Access DB and outputs a Word document that displays the information visually using ASCII characters and shading.
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.