RTF Macro for Tables and Bullets - Applying Styles Example

[arronrouseedf]

The standard RTF table example is very simple. Thought this might be useful for others to use or adapt. This macro can be inserted into an RTF descriptor for Organizational Process objects. It will produce a list of Operations and their responsible Org-Units in a nicely formatted table and replace any nasty-looking RTF bullets with proper Word bullet styles.

Option Explicit

' oObject               Current occurrence
' oContext
'   oContext.StyleSheet     Stylesheet that is used
'   oContext.Current        Current occurrence
'   oContext.Parent         Parent occurrence from a link or request
'   oContext.Root           Entry point occurrence of the description
'   oContext.Document       Current MEGA document
'   oContext.GenerationMode rtf generation mode
'   oContext.IsConfidential oObject As MegaObject. return bIsConfidential As bool

' sUserData             Unused
' sResult               rtf text to be inserted in the document during generation


Public Sub BulletReplacer(oWordApplication, oWordDocument)
    TurnBulletIntoStyle "^0183", "My Table List Bullet", oWordApplication, oWordDocument
    TurnBulletIntoStyle ChrW(61623), "My Table List Bullet", oWordApplication, oWordDocument
    TurnBulletIntoStyle "o", "My Table List Bullet 2nd Indent", oWordApplication, oWordDocument
    TurnBulletIntoStyle "-", "My Table List Bullet 3rd Indent", oWordApplication, oWordDocument
End Sub


Private Sub TurnBulletIntoStyle(strBulletChar, strReplacementStyle, oWordApplication, oWordDocument)
  ' Explanation of parameters
  ' strBulletChar       - when you paste text with bullets into an RTF attibute, e.g. the Comments section of an Operation object,
  '                       the bullets get turned into characters and tabs. This sub finds every strBulletChar followed by a tab.
  ' strReplacementStyle - the name of the bullet style in the MS Word .dot style sheet that the descriptor is using.
  
  Dim boolFormat ' As Boolean
  Dim boolMatchCase ' As Boolean
  Dim boolMatchWildcards ' As Boolean
  
  With oWordApplication      
    ' Get the current settings
    With .Selection.Find
        boolFormat = .Format
        boolMatchCase = .MatchCase
        boolMatchWildcards = .MatchWildcards
    End With
    
    ' Select everything
    .Selection.WholeStory
    .Selection.LanguageID = 2057
    .CheckLanguage = False
    .Selection.NoProofing = False
    
    ' Set up the find/replace
    .Selection.Find.ClearFormatting
    .Selection.Find.Replacement.ClearFormatting
    .Selection.Find.Replacement.Style = oWordDocument.Styles(strReplacementStyle)
    With .Selection.Find
      .Text = strBulletChar & "^t(?)"
      .Replacement.Text = "\1"
      .Forward = True
      .Wrap = 1
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchKashida = False
      .MatchDiacritics = False
      .MatchAlefHamza = False
      .MatchControl = False
      .MatchWildcards = True
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    
    ' Do the find/replace
    .Selection.Find.Execute ,,,,,,,,,,2
    
    ' Leave things how we found them
    With .Selection.Find
      .Format = boolFormat
      .MatchCase = boolMatchCase
      .MatchWildcards = boolMatchWildcards
    End With
  End With
End Sub


Function TableStyleApply(oTable)
  Const wdLineWidth050pt = 4
  Const wdLineStyleSingle = 1
  Const wdBorderTop = -1
  Const wdBorderLeft = -2
  Const wdBorderBottom = -3
  Const wdBorderRight = -4
  Const wdBorderHorizontal = -5
  Const wdBorderVertical = -6
  
  oTable.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
  oTable.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
  oTable.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
  oTable.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
  oTable.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
  oTable.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
  
  oTable.Rows(1).Range.Font.Bold = True
  oTable.Rows(1).HeadingFormat = True
  oTable.Rows(1).Shading.BackgroundPatternColor = 15132390
  
  oTable.Columns(1).SetWidth 78, 3
  oTable.Columns(2).SetWidth 285, 3
  oTable.Columns(3).SetWidth 75, 3

  oTable.Rows.LeftIndent = 43
End Function


Sub BuildOperationTable(oTable, oOperations, oContext)
  Dim intCount
  Dim oOperation
  Dim strCrLf
  Dim strOrgUnits
  Dim oOrgUnits
  Dim oOrgUnit
  
  intCount = oTable.Rows.Count

  oTable.Cell(intCount, 1).Range.Text = "Activity"
  oTable.Cell(intCount, 2).Range.Text = "Description"
  oTable.Cell(intCount, 3).Range.Text = "Roles"

  oTable.Cell(intCount, 1).Range.ParagraphFormat.Alignment = 1
  oTable.Cell(intCount, 2).Range.ParagraphFormat.Alignment = 1
  oTable.Cell(intCount, 3).Range.ParagraphFormat.Alignment = 1


  For Each oOperation in oOperations
    oTable.Rows.Add()

    intCount = intCount + 1
    
    strCrLf = ""
    strOrgUnits = ""
    Set oOrgUnits = oContext.Root.GetSelection("Select [Org-Unit] Where [Operation].([Name] = """ & oOperation.GetProp("Name", "Internal") & """ And ([Organizational Process] = """ & oContext.Current.GetProp("Name", "Internal") & """ Or [Organizational Process].[Aggregation of] = """ & oContext.Current.GetProp("Name", "Internal") & """) And [RACI] = 'Accountable') Or [Assigned Participants].([Performed Action]:[Operation].([Name] = """ & oOperation.GetProp("Name", "Internal") & """ And ([Organizational Process] = """ & oContext.Current.GetProp("Name", "Internal") & """ Or [Organizational Process].[Aggregation of] = """ & oContext.Current.GetProp("Name", "Internal") & """)) And [RACI] = 'Accountable')")
    For Each oOrgUnit in oOrgUnits
      strOrgUnits = strOrgUnits & strCrLf & oOrgUnit.GetProp("Short Name") & " (Accountable)"
      strCrLf = vbCrLf
    Next
    Set oOrgUnits = Nothing
    
    Set oOrgUnits = oContext.Root.GetSelection("Select [Org-Unit] Where [Operation].([Name] = """ & oOperation.GetProp("Name", "Internal") & """ And ([Organizational Process] = """ & oContext.Current.GetProp("Name", "Internal") & """ Or [Organizational Process].[Aggregation of] = """ & oContext.Current.GetProp("Name", "Internal") & """) And [RACI] = 'Responsible') Or [Assigned Participants].([Performed Action]:[Operation].([Name] = """ & oOperation.GetProp("Name", "Internal") & """ And ([Organizational Process] = """ & oContext.Current.GetProp("Name", "Internal") & """ Or [Organizational Process].[Aggregation of] = """ & oContext.Current.GetProp("Name", "Internal") & """)) And [RACI] = 'Responsible')")
    For Each oOrgUnit in oOrgUnits
      strOrgUnits = strOrgUnits & strCrLf & oOrgUnit.GetProp("Short Name") & " (Responsible)"
      strCrLf = vbCrLf
    Next
    Set oOrgUnits = Nothing
    
    Set oOrgUnits = oContext.Root.GetSelection("Select [Org-Unit] Where [Operation].([Name] = """ & oOperation.GetProp("Name", "Internal") & """ And ([Organizational Process] = """ & oContext.Current.GetProp("Name", "Internal") & """ Or [Organizational Process].[Aggregation of] = """ & oContext.Current.GetProp("Name", "Internal") & """) And [RACI] = 'Support') Or [Assigned Participants].([Performed Action]:[Operation].([Name] = """ & oOperation.GetProp("Name", "Internal") & """ And ([Organizational Process] = """ & oContext.Current.GetProp("Name", "Internal") & """ Or [Organizational Process].[Aggregation of] = """ & oContext.Current.GetProp("Name", "Internal") & """)) And [RACI] = 'Support')")
    For Each oOrgUnit in oOrgUnits
      strOrgUnits = strOrgUnits & strCrLf & oOrgUnit.GetProp("Short Name") & " (Support)"
      strCrLf = vbCrLf
    Next
    Set oOrgUnits = Nothing
    
    oTable.Cell(intCount, 1).Range.Text = oOperation.GetProp("Short Name")
    oTable.Cell(intCount, 1).Range.ParagraphFormat.Alignment = 0
    oTable.Cell(intCount, 2).Range.Text = oOperation.GetProp("Comment", "display") & vbCrLf
    oTable.Cell(intCount, 2).Range.ParagraphFormat.Alignment = 0
    oTable.Cell(intCount, 3).Range.Text = strOrgUnits
    oTable.Cell(intCount, 3).Range.ParagraphFormat.Alignment = 0
  Next
End Sub

 
Sub Generate(oObject, oContext, sUserData, sResult)
  Dim oWordApplication ' As Word.Application
  Dim oWordDocument ' As Word.Document
  Dim strName
  Dim strERQL
  Dim oTable ' As Word.Table
  
  ' Get the name of the current Organizational Process
  strName = CStr(oContext.Current.GetProp("Name", "Internal"))
  
  ' Build the ERQL query to get the Operations
  strERQL = "Select [Operation] Where [Organizational Process] = """ & strName & """"

  ' If there are any Operations
  If oContext.Root.GetSelection(strERQL).Count > 0 Then
    ' Start MS Word and create a document
    Set oWordApplication = CreateObject("Word.Application")
    Set oWordDocument = oWordApplication.Documents.Add
    
    ' Attach the .dot file so that you get the styles you need
    oWordDocument.AttachedTemplate = oContext.StyleSheet
    oWordDocument.UpdateStyles
    oWordDocument.Paragraphs.Add
    Const wdWord8TableBehavior = 0
    
    ' Add the table for the Operations
    Set oTable = oWordDocument.Tables.Add(oWordDocument.Paragraphs.Last.Range, 1, 3, wdWord8TableBehavior)
    oTable.Range.Font.Name = "Arial"
    oTable.Range.Font.Size = 9
    
    ' Populate the table with the data from the repository
    BuildOperationTable oTable, oObject.Operation("Order", "Short Name"), oContext
    
    ' Apply the styles
    TableStyleApply oTable
    BulletReplacer oWordApplication, oWordDocument
    
    ' Save the RTF data back into Hopex so that it can be output to your final Word document
    oContext.Current.GetRoot.SaveWordDocumentAsRtf oWordDocument, sResult
    
    ' Clean up afterwards
    oWordApplication.Quit 0
    Set oTable = Nothing
    Set oWordDocument = Nothing
    Set oWordApplication = Nothing
  End If
End Sub