vb.netms-word

vb.net Word Table Formatting


I have been trying to figure out how to force word tables to under line until the end of the cell. I appear to be having issues if lines are to long and/or to short. I am not a word expert, however I am assuming that all characters are not the same size...

enter image description here

This is what the code produces

enter image description here

Below is the code I used to create the above. I would think that I should be able to check the cell length? Any help would be appreciated.

Public Shared Sub CreateWordDocument() Try Dim oWord As Word.Application Dim oDoc As Word.Document

        'Start Word and open the document template.
        oWord = CreateObject("Word.Application")
        oWord.Visible = True
        oDoc = oWord.Documents.Add

        Dim Row As Integer, Column As Integer
        Dim myTable As Word.Table = oDoc.Tables.Add(oDoc.Bookmarks.Item("\endofdoc").Range, 10, 2)

        myTable.Range.ParagraphFormat.SpaceAfter = 1

        Dim mystring As String = "This is my Test name That Runs over to the next line"
        Dim address1 As String = "123 1st fake street"
        Dim address2 As String = "Fake town place"

        Dim mystring2 As String = "This is good line"
        Dim address3 As String = "321 3rd fake street"
        Dim address4 As String = "Fake town place"
        Dim line As String = "_"

        For Row = 1 To 10

            If Row <> 5 Then
                myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
                myTable.Rows.Item(Row).Range.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphLeft
                myTable.Rows.Item(Row).Range.Font.Bold = False
                myTable.Rows.Item(Row).Range.Font.Size = 11
                myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
            End If
            For Column = 1 To 2

                If Column = 1 And Row = 1 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(mystring)
                ElseIf Column = 1 And Row = 2 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address1)
                ElseIf Column = 1 And Row = 3 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address2)
                ElseIf Column = 2 And Row = 1 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(mystring2)
                ElseIf Column = 2 And Row = 2 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address3)
                ElseIf Column = 2 And Row = 3 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address4)
                Else
                    myTable.Cell(Row, Column).Range.Text = GetString(line)
                End If
            Next
        Next

        Dim strCellText As String
        Dim uResp As String

        Dim itable As Table

        For Each itable In oDoc.Tables
            uResp = ""
            For Row = 1 To itable.Rows.Count
                For Col = 1 To itable.Columns.Count
                    strCellText = itable.Cell(Row, Col).Range.Text
                    If strCellText.Length >= 33 Then
                        Console.Write("this will be on a different line")
                    ElseIf strCellText.Length <= 31 Then
                        Console.Write("this will be on a different line")
                    End If
                Next
            Next
        Next

    Catch ex As Exception

    End Try


End Sub

Public Shared Function GetString(ByVal strGetLine As String) As String

    If strGetLine.Length <> 30 Then
        Do Until strGetLine.Length >= 30
            strGetLine += "_"
            Dim count As String = strGetLine.Length
        Loop
    End If

    Return strGetLine

End Function

Solution

  • There are two parts to your problem. One is the font. Because you are padding each line with "_" to a predetermined width, you must use a monospaced font or the lines will end unevenly. With a monospaced font, each character will take up the same width which will give you your uniform lines. Second, the GetString function takes any line less than 30 characters and pads it, but it does not handle any lines that are over 30 characters which is why the line wraps by itself. To solve these two problems, I set the font to a monospaced font (Courier New in this case) and modified the GetString function's logic. Now, if the line is more than 30 characters, the function will find a space where it can split the string as close as possible to the 30-char limit and add a break there, before padding both lines with underscores. Here is your code with the changes included:

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        'Added these two Dim's so I could run your example
        Dim oWord As Object
        Dim oDoc As Document
    
        oWord = CreateObject("Word.Application")
        oWord.Visible = True
        oDoc = oWord.Documents.Add
    
        Dim Row As Integer, Column As Integer
        Dim myTable As Word.Table = oDoc.Tables.Add(oDoc.Bookmarks.Item("\endofdoc").Range, 10, 2)
    
        myTable.Range.ParagraphFormat.SpaceAfter = 1
    
        Dim mystring As String = "This is my Test name That Runs over to the next line"
        Dim address1 As String = "123 1st fake street"
        Dim address2 As String = "Fake town place"
    
        Dim mystring2 As String = "This is good line"
        Dim address3 As String = "321 3rd fake street"
        Dim address4 As String = "Fake town place"
        Dim line As String = "_"
    
        For Row = 1 To 10
            'Removed this If, because all lines need font set to ensure same width, even if line has no text
            'If Row <> 5 Then
            myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
            myTable.Rows.Item(Row).Range.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphLeft
            myTable.Rows.Item(Row).Range.Font.Bold = False
            myTable.Rows.Item(Row).Range.Font.Size = 11
            myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
            myTable.Rows.Item(Row).Range.Font.Name = "Courier New" 'Set font to a monospaced font
            'End If
    
            For Column = 1 To 2
                If Column = 1 And Row = 1 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(mystring)
                ElseIf Column = 1 And Row = 2 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address1)
                ElseIf Column = 1 And Row = 3 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address2)
                ElseIf Column = 2 And Row = 1 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(mystring2)
                ElseIf Column = 2 And Row = 2 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address3)
                ElseIf Column = 2 And Row = 3 Then
                    myTable.Cell(Row, Column).Range.Text = GetString(address4)
                Else
                    myTable.Cell(Row, Column).Range.Text = GetString(line)
                End If
            Next
        Next
    
        Dim strCellText As String
        Dim uResp As String
        Dim itable As Table
        For Each itable In oDoc.Tables
            uResp = ""
            For Row = 1 To itable.Rows.Count
                For Col = 1 To itable.Columns.Count
                    strCellText = itable.Cell(Row, Col).Range.Text
                    If strCellText.Length >= 33 Then
                        Console.Write("this will be on a different line")
                    ElseIf strCellText.Length <= 31 Then
                        Console.Write("this will be on a different line")
                    End If
                Next
            Next
        Next
    End Sub
    
    Public Shared Function GetString(ByVal strGetLine As String) As String
        'If strGetLine.Length <> 30 Then
        '    Do Until strGetLine.Length >= 30
        '        strGetLine += "_"
        '        Dim count As String = strGetLine.Length
        '    Loop
        'End If
        'New Function Logic:
    
        'If the line is just a blank line, then just send back 30 underscores
        If strGetLine.Trim.Equals("_") Then Return strGetLine.PadRight(30, "_")
    
        Dim ret As String = Nothing
        If strGetLine.Length > 30 Then
            Dim lineBreak As Integer = 0
            If strGetLine.Length >= 30 Then
                Dim i As Integer = 0
                Do While i <= 30
                    i = strGetLine.IndexOf(" ", i + 1)
                    If i <= 30 Then lineBreak = i
                Loop
            End If
            ret = strGetLine.Substring(0, lineBreak).Trim.PadRight(30, "_") & vbCrLf
            ret &= strGetLine.Substring(lineBreak, strGetLine.Length - lineBreak).Trim.PadRight(30, "_")
        Else
            ret = strGetLine.PadRight(30, "_")
        End If
        Return ret
    End Function
    

    Which outputs:

    Line Test

    Now I'm sure you'll notice, there appears to be a blank line in the right column (the rest of the blank lines are from the 10 row loop). This is simply because the other column of the same row has two lines. I don't know if that's what you would want or not, but if you want both columns to have the appearance of the same number of lines, you will have to keep track of if you split a line in column 1, and add an extra blank line to column two...but this should get you going in the right direction