module_vba.bas

业余做的水利工程压力管道质检表自生成软件！

Attribute VB_Name = "Module_VBA"
'处理表格
'参阅特性本主题包含与下列任务相关的 Visual Basic 示例：

'创建一张表格，插入文字，并应用格式
'下列示例在活动文档的开头插入一张 4 列 3 行的表格。For Each...Next 结构用
'于循环遍历表格中的每个单元格。在 For Each...Next 结构中，InsertAfter 方
'法用于将文字添至表格单元格（单元格 1、单元格 2、以此类推）。
Sub CreateNewTable()
    Dim docActive As Document
    Dim tblNew As Table
    Dim celTable As Cell
    Dim intCount As Integer

    Set docActive = ActiveDocument
    Set tblNew = docActive.Tables.Add( _
        Range:=docActive.Range(Start:=0, End:=0), NumRows:=3, _
        NumColumns:=4)
    intCount = 1

    For Each celTable In tblNew.Range.Cells
        celTable.Range.InsertAfter "Cell " & intCount
        intCount = intCount + 1
    Next celTable

    tblNew.AutoFormat Format:=wdTableFormatColorful2, _
        ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True
End Sub

'在表格单元格中插入文字
'下列示例在活动文档中第一张表格的第一个单元格中插入文字?Cell 方法返回单
'独的 Cell 对象。Range 属性返回一个 Range 对象。Delete 方法用于删除现有
'的文字，而 InsertAfter 方法用于插入文字“Cell 1,1”。
Sub InsertTextInCell()
    If ActiveDocument.Tables.Count >= 1 Then
        With ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range
            .Delete
            .InsertAfter Text:="Cell 1,1"
        End With
    End If
End Sub

'返回表格单元格中的文字，不包括表格结束单元格标记
'下列示例返回并显示文档中第一张表格的第一行中每个单元格的内容?
Sub ReturnTableText()
    Dim tblOne As Table
    Dim celTable As Cell
    Dim rngTable As Range

    Set tblOne = ActiveDocument.Tables(1)
    For Each celTable In tblOne.Rows(1).Cells
        Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
            End:=celTable.Range.End - 1)
        MsgBox rngTable.Text
    Next celTable
End Sub
Sub ReturnCellText()
    Dim tblOne As Table
    Dim celTable As Cell
    Dim rngTable As Range

    Set tblOne = ActiveDocument.Tables(1)
    For Each celTable In tblOne.Rows(1).Cells
        Set rngTable = celTable.Range
        rngTable.MoveEnd Unit:=wdCharacter, Count:=-1
        MsgBox rngTable.Text
    Next celTable
End Sub

'将文本转换为表格
'下列示例在活动文档的开头插入用制表符分隔的文本，然后将这些文本转换为表格。
Sub ConvertExistingText()
    With Documents.Add.Content
        .InsertBefore "one" & vbTab & "two" & vbTab & "three" & vbCr
        .ConvertToTable Separator:=Chr(9), NumRows:=1, NumColumns:=3
    End With
End Sub

'返回每个表格单元格的内容
'下列示例定义一个数组，该数组的元素个数等于文档中第一张表格（假定为 Option Base 1）
'中的单元格数。For Each...Next 结构用于返回每个表格单元格的内容，并将文字指定给相应的数组元素。
Sub ReturnCellContentsToArray()
    Dim intCells As Integer
    Dim celTable As Cell
    Dim strCells() As String
    Dim intCount As Integer
    Dim rngText As Range

    If ActiveDocument.Tables.Count >= 1 Then
        With ActiveDocument.Tables(1).Range
            intCells = .Cells.Count
            ReDim strCells(intCells)
            intCount = 1
            For Each celTable In .Cells
                Set rngText = celTable.Range
                rngText.MoveEnd Unit:=wdCharacter, Count:=-1
                strCells(intCount) = rngText
                intCount = intCount + 1
            Next celTable
        End With
    End If
End Sub

'将活动文档中的所有表格复制到新文档中
'本示例将当前文档中的表格复制到新文档中?
Sub CopyTablesToNewDoc()
    Dim docOld As Document
    Dim rngDoc As Range
    Dim tblDoc As Table

    If ActiveDocument.Tables.Count >= 1 Then
        Set docOld = ActiveDocument
        Set rngDoc = Documents.Add.Range(Start:=0, End:=0)
        For Each tblDoc In docOld.Tables
            tblDoc.Range.Copy
            With rngDoc
                .Paste
                .Collapse Direction:=wdCollapseEnd
                .InsertParagraphAfter
                .Collapse Direction:=wdCollapseEnd
            End With
        Next
    End If
End Sub

Public Sub Add_Table() '创建表格,插入文字

    SetoDoc = ActiveDocument
    SetoTable = oDoc.Tables.Add(Range:=oDoc.Range(Start:=0, End:=0), NumRows:=3, NumColumns:=4)
    iCount = 1
    For Each oCell In oTable.Range.Cells
        oCell.Range.InsertAfter "第" & iCount & "单元格"
        iCount = iCount + 1
    Next oCell
    oTable.AutoFormat Format:=wdTableFormatColorful2, ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True

End Sub

Public Sub Add_XL1() '第一列插入序号
    If iCount Mod 4 = 1 Then
        oCell.Range.InsertAfter "第" & (iCount - 1) / 4 & "行"
    End If
    iCount = iCount + 1

End Sub

Public Sub Add_XL2() '从表格的第二行开始插入序号
    If iCount Mod 4 = 1 And iCount > 4 Then
        oCell.Range.InsertAfter "第" & (iCount - 1) / 4 & "行"
    End If
    iCount = iCount + 1

End Sub

Public Sub Add_Date1() '在表格的第一列插入日期
    SetoDoc = ActiveDocument
    SetoTable = oDoc.Tables.Add(Range:=oDoc.Range(Start:=0, End:=0), NumRows:=4, NumColumns:=4)
    iCount = 1
    Dim cWeekName(7)
    cWeekName(1) = "星期日"
    cWeekName(2) = "星期一"
    cWeekName(3) = "星期二"
    cWeekName(4) = "星期三"
    cWeekName(5) = "星期四"
    cWeekName(6) = "星期五"
    cWeekName(7) = "星期六"
    For Each oCell In oTable.Range.Cells
        If iCount Mod 4 = 1 And iCount > 4 Then
            oCell.Range.InsertAfter Format(Date, (iCount - 1) / 4, "YYYY.MM.DD")
        End If
        If iCount Mod 4 = 2 And iCount > 4 Then
            oCell.Range.InsertAfter cWeekName(Weekday(Date, (iCount - 1) / 4))
        End If
        iCount = iCount1
    Next oCell
    oTable.AutoFormat Format:=wdTableFormatColorful1, ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True

End Sub

Public Sub Chang_Color() '根据单元格的内容设置不同的格式
    iCount = 1
    For Each Rows In oTable.Range.Rows
        If (Weekday(Date, (iCount - 1)) = 7 Or Weekday(Date, (iCount - 1)) = 1) And iCount > 1 Then
            Selection.SelectRow
            With Selection.Cells
                With .Shading
                     .Texture = wdTextureNone
                     .ForegroundPatternColorIndex = wdAuto
                     .BackgroundPatternColorIndex = wdBlue
                End With
            End With
        End If
        iCount = iCount + 1
        Selection.MoveDown Unit:=wdLine, Count:=1
      Next Rows

End Sub


'六) 表格集合中的循环与对单元格边框的设置
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Sub Example()
    Dim i As Table, N As Integer
    On Error Resume Next '忽略错误
    Application.ScreenUpdating = False '关闭屏幕更新
    For Each i In ActiveDocument.Tables '在表格中循环
        With i
            .Style = "列表型 4" '将所有表格设置为"列表型4"的样式
            With .Borders '边框
                 .InsideLineStyle = wdLineStyleSingle '设置内部边框线条
            End With
            With .Rows(1).Borders(wdBorderBottom) '第一行的底边框
                 .LineStyle = wdLineStyleDouble '双线型
                 .LineWidth = wdLineWidth050pt
                 .Color = wdColorAutomatic
            End With
            If .Rows.Count > 1 Then ' 如果表格行数大于1
                If Len(.Cell(2, 1).Range) <= 2 Then '如果第二行第一列不为空
                    With .Rows(2).Shading '设置底纹
                         .Texture = wdTextureNone '无底底纹
                         .ForegroundPatternColor = wdColorAutomatic
                         .BackgroundPatternColor = wdColorGray125
                    End With
                End If
            End If
            For N = 2 To .Columns.Count '从第二列到最后一列
                .Columns(N).Select '单元格对齐方式为中部居中
                Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
            Next N
        End With
    Next i
    Application.ScreenUpdating = True
End Sub