Created
January 19, 2014 08:17
-
-
Save chellinsky/8501886 to your computer and use it in GitHub Desktop.
Takes information from an Access DB and outputs a Word document that displays the information visually using ASCII characters and shading.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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