Writing Landscape Text into Microsoft Word Document

For a book I am writing using Microsoft Word, I needed to include some source code listings. These listings are wider than will fit  in a portrait orientation, so I needed them to be landscape. I could create sections that are landscape, but the publisher I am using can't deal with that, so I needed them to be landscape text on a portrait page. I also needed to be able to re-add the listings if the source code changed. This sounds like a job for VBA. Below is the code that I wrote.

I add textboxes to each page, and then fill the textbox with the vertical text.

Option Explicit
' Copyright © 2015 Xoc Software
' Put source listings landscape on a page
' Applies two styles RotatedFileName and RotatedCode

Public Sub AddSourceListings()
    Dim shape As shape
    Dim files As Collection
    Dim strsFileNames As Collection
    Dim strFileName As String
    Dim varFileName As Variant
    Dim i As Long
    Dim lngLineNumber As Long
    Dim varLine As Variant
    
    'Maximum lines per page...adjust to page width
    Const lngMaxLines As Long = 35
    
    Set files = New Collection
    Set strsFileNames = New Collection
    
    'FileNames to document
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.CoverGenerator\Properties\AssemblyInfo.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.CoverGenerator\GraphicsExtensions.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.CoverGenerator\PageType.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.CoverGenerator\Program.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.Penrose\Properties\AssemblyInfo.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.Penrose\RhombusTiler.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.Penrose\RhombusType.cs"
    strsFileNames.Add "c:\src.cs\Xoc.CoverGenerator\Xoc.Penrose\Triangle.cs"
    
    For Each varFileName In strsFileNames
        files.Add ProcessFile(varFileName)
    Next varFileName
    
    lngLineNumber = 0
    Set shape = AddPage
    For i = 1 To files.Count
        If lngLineNumber >= lngMaxLines Then
            Set shape = AddPage
            lngLineNumber = 0
        End If
        With shape.TextFrame
            strFileName = strsFileNames(i)
            
            'Remove up through the first slash each time
            strFileName = Mid$(strFileName, InStr(1, strFileName, "\") + 1)
            strFileName = Mid$(strFileName, InStr(1, strFileName, "\") + 1)
            strFileName = Mid$(strFileName, InStr(1, strFileName, "\") + 1)
            .TextRange.InsertAfter strFileName
            .TextRange.Select
            Selection.Collapse wdCollapseEnd
            Selection.Style = "RotatedFileName"
            .TextRange.InsertParagraphAfter
            .TextRange.Select
            Selection.Collapse wdCollapseEnd
            Selection.Style = "RotatedCode"
        End With
        lngLineNumber = lngLineNumber + 2
       
        For Each varLine In files(i)
            shape.TextFrame.TextRange.InsertAfter varLine & Chr(11)
            lngLineNumber = lngLineNumber + 1
            If lngLineNumber >= lngMaxLines Then
                shape.TextFrame.TextRange.InsertParagraphAfter
                Set shape = AddPage
                shape.TextFrame.TextRange.Select
                Selection.Collapse wdCollapseEnd
                Selection.Style = "RotatedCode"
                lngLineNumber = 0
            End If
        Next varLine
        shape.TextFrame.TextRange.InsertParagraphAfter
        lngLineNumber = lngLineNumber + 1
    Next i
    
    Set strsFileNames = Nothing
    Set files = Nothing
End Sub

Private Function AddPage() As shape
    Dim doc As Document
    Dim section As section
    
    Set doc = Application.ActiveDocument
    Set section = doc.Sections.Add
    section.Range.Select
    Selection.Collapse wdCollapseEnd
    
    'Size the textbox on the page, adjust to page size and margins
    Set AddPage = doc.Shapes.AddTextbox(Orientation:=msoTextOrientationUpward, Left:=54, Top:=54, Width:=324, Height:=540)
End Function

Private Function ProcessFile(ByVal strFileName As String) As Collection
    Dim strLine As String
    Dim boolFirst As Boolean
    Dim lines As Collection
    
    Set lines = New Collection
    
    boolFirst = True
    
    Open strFileName For Input As #1
    
    Do Until EOF(1)
        Line Input #1, strLine
        strLine = Replace(strLine, Chr(9), "     ")
        
        'Remove some miscellanous stuff Visual Studio adds to files
        strLine = Replace(strLine, "", "")
        strLine = Replace(strLine, "Â", "")
        lines.Add strLine
    Loop
    Close #1
    Set ProcessFile = lines
    Set lines = Nothing
End Function

Getting the Fonts in Use in a Word Document

Word does not provide an easy way to get a list of the fonts in use inside the document. Here is a VBA macro that will provide that list. In word, press Alt+F11, Select Insert Module from the menu, and paste the code below. Then from the View ribbon, click Macros, select XocListFonts from the list, then click Run. It will show a MessageBox with the names of all the typefaces in use inside the document. When you save the document, you will need to save it as a Macro Enabled Document, otherwise the code will be removed.

Public Sub XocListFonts()
    On Error GoTo ErrorHandler
    Dim rngStory As Range
    Dim rngChar As Range
    Dim strsFontNames As Collection
    Dim strFontOld As String
    Dim strFontCur As String
    Dim strFontName As String
    Dim objFontName As Variant
    Dim Number As Integer
    Dim strFonts As String
    
    Set strsFontNames = New Collection
    For Each rngStory In ActiveDocument.StoryRanges
        strFontOld = ""
        If rngStory.End > 1 Then
            Set rngChar = rngStory.Characters(1)
            Do
                strFontCur = rngChar.Font.Name
                If strFontCur <> strFontOld Then
                    strFontOld = strFontCur
                    
                    ' This causes a runtime error if the font doesn't exist
                    objFontName = strsFontNames.Item(strFontCur)
                End If
                rngChar.MoveStart wdCharacter, 1
                rngChar.MoveEnd wdCharacter, 1
            Loop Until rngChar.End = rngStory.End
        End If
    Next rngStory
    
    For Each objFontName In strsFontNames
        strFonts = strFonts & objFontName & vbCrLf
    Next objFontName
    MsgBox strFonts
Exit Sub
ErrorHandler:
    Number = Err.Number
    Select Case Number
        Case 5 'Invalid Procedure Call
            strsFontNames.Add strFontCur, strFontCur
            Resume Next
        Case Else
            MsgBox "Unexpected Error #" & Number & vbCrLf & Err.Description
    End Select
End Sub

An alternate way to get a list is to save the document as a PDF file. Then open the PDF file in Adobe Reader. From the File menu, select Properties. Then click the fonts tab. Adobe is a little more explicit about the fonts, differentiating Bold and Italic fonts from the normal font.