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