Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Jun 2012
    Posts
    11
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Help with a Table Macro

    Hey All,

    Was wondering if you all could help me with this table macro? I want the macro to create a title and sub-title for a table then create the set number of columns and rows of the table i selected, then underneath have a line for the "source" of the info

    Any help possible would be great

    Code:
    Sub Table_Insert()
    
    '
    ' Table_title Macro
    '
    '
        Selection.Style = ActiveDocument.Styles("Figure/Table/Box Title ESC")
        Selection.TypeText Text:="Table ?.?" & vbTab & "<<Insert title>>"
        With Selection.ParagraphFormat
            .LeftIndent = MillimetersToPoints(23)
            .RightIndent = MillimetersToPoints(0)
            .SpaceBefore = 18
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = True
            .KeepWithNext = True
            .KeepTogether = True
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = True
            .FirstLineIndent = MillimetersToPoints(-23)
            .OutlineLevel = wdOutlineLevel3
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
            .MirrorIndents = False
            .TextboxTightWrap = wdTightNone
        End With
        Selection.TypeParagraph
        Selection.Style = ActiveDocument.Styles("Figure/Table Subtitle")
        Selection.TypeText Text:=vbTab & "<<Insert subtitle>>"
        Selection.TypeParagraph
        
    '******************************** InsertTable ********************************
    '* Mimics the Insert Table dialog
    '*****************************************************************************
    Dim PageDlg As Object
    Dim Margins
    Dim PageWidth
    WordBasic.BeginDialog 385, 103, "Insert Table"
        WordBasic.Text 10, 10, 152, 13, "Number of Columns:"
        WordBasic.Text 10, 31, 131, 13, "Number of Rows:"
        WordBasic.Text 10, 52, 111, 13, "Column Width:"
        WordBasic.Text 10, 83, 300, 13, "(No. of Rows must be at least 4)"
        WordBasic.Textbox 186, 7, 85, 18, "Columns"
        WordBasic.Textbox 186, 28, 85, 18, "Rows"
        WordBasic.Textbox 186, 49, 85, 18, "ColumnWidth"
        WordBasic.OKButton 286, 6, 88, 21
        WordBasic.CancelButton 286, 30, 88, 21
    WordBasic.EndDialog
    
    Dim dlg As Object: Set dlg = WordBasic.CurValues.UserDialog
    dlg.Rows = "4"
    dlg.ColumnWidth = "Auto"
    If Not WordBasic.Dialog.UserDialog(dlg) Then GoTo bye
    WordBasic.ScreenRefresh
    Select Case dlg.ColumnWidth <> "Auto"
    Case -1
        WordBasic.TableInsertTable numColumns:=dlg.Columns, numRows:=dlg.Rows, InitialColWidth:=dlg.ColumnWidth
    
    Case Else
        Set PageDlg = WordBasic.DialogRecord.FilePageSetup(False): PageDlg.Tab = 0: WordBasic.CurValues.FilePageSetup PageDlg
        Margins = WordBasic.Val(PageDlg.LeftMargin) + WordBasic.Val(PageDlg.RightMargin) + WordBasic.Val(PageDlg.Gutter)
        PageDlg.Tab = 1: WordBasic.CurValues.FilePageSetup PageDlg
        PageWidth = WordBasic.Val(PageDlg.PageWidth) - Margins
        WordBasic.TableInsertTable numColumns:=dlg.Columns, numRows:=dlg.Rows, InitialColWidth:=Str(PageWidth / WordBasic.Val(dlg.Columns))
    End Select
    WordBasic.TableSelectTable
    
    bye:
    
    Selection.Tables(1).Style = "Table"
        Selection.Style = ActiveDocument.Styles("Table Heading ESC")
    
    '
    ' TableSource Macro
    '
    '
        Selection.Style = ActiveDocument.Styles("Figure/Table/Box Title ESC")
        Selection.Style = ActiveDocument.Styles("Notes/Sources ESC")
        Selection.TypeText Text:="a A note"
    
        Selection.TypeParagraph
        Selection.Style = ActiveDocument.Styles("Notes/Sources ESC")
    
        Selection.TypeText Text:="Source: <<Insert source>>"
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=7
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Selection.Style = ActiveDocument.Styles("Note Label")
        Selection.MoveRight Unit:=wdCharacter, Count:=8
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=13
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=2
        Selection.MoveLeft Unit:=wdCharacter, Count:=2
        Selection.MoveRight Unit:=wdCharacter, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=2
        
    End Sub

  2. #2
    New Lounger
    Join Date
    Jun 2012
    Posts
    11
    Thanks
    2
    Thanked 0 Times in 0 Posts
    I think this is solution

    Code:
    Public Sub ESCTable()
        TableHeader
        InsertTable
        FormatTable 1
        TableSource
    End Sub
    
    Private Sub TableHeader()
    '
    ' TableHeader Macro
    '
    '
        Selection.Style = ActiveDocument.Styles("Figure/Table/Box Title ESC")
        Selection.TypeText Text:="Table ?.?" & vbTab & "<<Insert title>>"
        With Selection.ParagraphFormat
            .LeftIndent = MillimetersToPoints(23)
            .RightIndent = MillimetersToPoints(0)
            .SpaceBefore = 18
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = True
            .KeepWithNext = True
            .KeepTogether = True
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = True
            .FirstLineIndent = MillimetersToPoints(-23)
            .OutlineLevel = wdOutlineLevel3
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
            .MirrorIndents = False
            .TextboxTightWrap = wdTightNone
        End With
        Selection.TypeParagraph
        Selection.Style = ActiveDocument.Styles("Figure/Table Subtitle")
        Selection.TypeText Text:=vbTab & "<<Insert subtitle>>"
        Selection.TypeParagraph
    End Sub
    
    '******************************** InsertTable ********************************
    '* Mimics the Insert Table dialog
    '*****************************************************************************
    Private Sub InsertTable()
    Dim PageDlg As Object
    Dim Margins
    Dim PageWidth
    WordBasic.BeginDialog 385, 103, "Insert Table"
        WordBasic.Text 10, 10, 152, 13, "Number of Columns:"
        WordBasic.Text 10, 31, 131, 13, "Number of Rows:"
        WordBasic.Text 10, 52, 111, 13, "Column Width:"
        WordBasic.Text 10, 83, 300, 13, "(No. of Rows must be at least 4)"
        WordBasic.Textbox 186, 7, 85, 18, "Columns"
        WordBasic.Textbox 186, 28, 85, 18, "Rows"
        WordBasic.Textbox 186, 49, 85, 18, "ColumnWidth"
        WordBasic.OKButton 286, 6, 88, 21
        WordBasic.CancelButton 286, 30, 88, 21
    WordBasic.EndDialog
    
    Dim dlg As Object: Set dlg = WordBasic.CurValues.UserDialog
    dlg.Rows = "4"
    dlg.ColumnWidth = "Auto"
    If Not WordBasic.Dialog.UserDialog(dlg) Then GoTo bye
    WordBasic.ScreenRefresh
    Select Case dlg.ColumnWidth <> "Auto"
    Case -1
        WordBasic.TableInsertTable NumColumns:=dlg.Columns, numRows:=dlg.Rows, InitialColWidth:=dlg.ColumnWidth
    
    Case Else
        Set PageDlg = WordBasic.DialogRecord.FilePageSetup(False): PageDlg.Tab = 0: WordBasic.CurValues.FilePageSetup PageDlg
        Margins = WordBasic.Val(PageDlg.LeftMargin) + WordBasic.Val(PageDlg.RightMargin) + WordBasic.Val(PageDlg.Gutter)
        PageDlg.Tab = 1: WordBasic.CurValues.FilePageSetup PageDlg
        PageWidth = WordBasic.Val(PageDlg.PageWidth) - Margins
        WordBasic.TableInsertTable NumColumns:=dlg.Columns, numRows:=dlg.Rows, InitialColWidth:=Str(PageWidth / WordBasic.Val(dlg.Columns))
    End Select
    WordBasic.TableSelectTable
    bye:
    End Sub
    
    '******************************** FormatTable ********************************
    '* Table should be selected when this subroutine runs
    '*****************************************************************************
    Private Sub FormatTable(NewTable)
    Dim numRows
    Dim n
    Dim NumCols
    Dim Margins
    Dim PageWidth
    Dim ColWidth
    Dim FSIdlg As Object: Set FSIdlg = WordBasic.DialogRecord.filesummaryinfo(False)
    WordBasic.CurValues.filesummaryinfo FSIdlg
    numRows = WordBasic.SelInfo(15)
    
    WordBasic.FormatStyle "Table Style ESC", Apply:=1
    
    
    Select Case NewTable
    Case -1                         'Should contain 4 rows - see InsertTable above
        FormatHeadingRow
        WordBasic.LineDown
        WordBasic.TableSelectRow
        WordBasic.FormatStyle "Table Style ESC", Apply:=1
    
        NextRow 2
    
    Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.Tables(1).Select
    WordBasic.LineDown 1
    WordBasic.LineUp 1
    
        WordBasic.TableSelectRow
        FormatLastRow
        WordBasic.LineDown
    Case Else
        Select Case numRows
        Case 2
            FormatHeadingRow
            NextRow 2
    Rem         LineDown 2
        Case 3
            FormatHeadingRow
            NextRow 2
    Rem         LineDown 2
            WordBasic.TableSelectRow
            FormatLastRow
            WordBasic.LineDown
            For n = 3 To numRows
    Rem         For n = 3 To numRows
                NextRow 1
            Next
            WordBasic.TableSelectRow
            FormatLastRow
            WordBasic.LineDown
            End Select
    End Select
    
    ByeBye:
    
    WordBasic.LineDown 2
    
    End Sub
    
    Private Sub FormatHeadingRow()
    WordBasic.FormatStyle "Table Style ESC", Apply:=1
    End Sub
    
    Private Sub FormatLastRow()
    WordBasic.FormatStyle "Table Style ESC", Apply:=1
    End Sub
    
    Private Sub NextRow(Count_)
    Dim numRows
    Dim i
    Dim ThisRow
    numRows = WordBasic.SelInfo(15)
    Select Case Count_
    Case Is < 1
        Count_ = 1
    Case Is > numRows
        Count_ = numRows
    Case Else
    End Select
    For i = 1 To Count_
        ThisRow = WordBasic.SelInfo(13)
        If ThisRow < numRows Then
            While ThisRow = WordBasic.SelInfo(13)
                WordBasic.LineDown
            Wend
        Else
            WordBasic.LineDown
        End If
    Next
    End Sub
    
    Sub TableSource()
    '
    ' TableSource Macro
    '
    '
        Selection.Style = ActiveDocument.Styles("Figure/Table/Box Title ESC")
        Selection.Style = ActiveDocument.Styles("Notes/Sources ESC")
        Selection.TypeText Text:="a A note"
    
        Selection.TypeParagraph
        Selection.Style = ActiveDocument.Styles("Notes/Sources ESC")
    
        Selection.TypeText Text:="Source: <<Insert source>>"
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=7
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Selection.Style = ActiveDocument.Styles("Note Label")
        Selection.MoveRight Unit:=wdCharacter, Count:=8
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=13
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveUp Unit:=wdLine, Count:=1
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveRight Unit:=wdCharacter, Count:=2
        Selection.MoveLeft Unit:=wdCharacter, Count:=2
        Selection.MoveRight Unit:=wdCharacter, Count:=1
        Selection.MoveLeft Unit:=wdCharacter, Count:=2
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •