module_word.bas

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

Attribute VB_Name = "Module_Word"
Public wD As Word.Application
Public px As Word.Paragraph '代表选定内容、范围或文档内的一个段落。
Public rng As Word.Range '该对象代表文档中的一个连续范围
Public tabx As Word.Tables

Public Function Scz(zyxm, pc, ds, row, col, tbn) '实测值及合格点数、合格率统计 row,col行列 第tbn个表  pc允许偏差
    Dim tpc, hg, tp, tmp '临时变量
    Dim tabn As Word.Table
    Set tabn = wD.ActiveDocument.Tables(tbn)
    If zyxm = 2 Then tpc = pc * 1.1 Else tpc = pc
    hg = 0
    tp = 1
    For tp = 1 To ds
        tmp = Int(tpc * Rnd * 10) / 10
        If tmp < pc Or tmp = pc Then hg = hg + 1
        If tmp < 1 And tmp > 0 Then tmp = "0" & Trim(Str$(tmp)) Else tmp = Trim(Str$(tmp))
        If tp = 1 Then tabn.Cell(row, col).Range.Text = tmp Else tabn.Cell(row, col).Range.InsertAfter tmp
        If tp = ds Then Exit For Else tabn.Cell(row, col).Range.InsertAfter ","
    Next tp
    tabn.Cell(row, col + 1).Range.Text = Str$(hg) '合格数
    tabn.Cell(row, col + 2).Range.Text = Str$(Int(hg / ds * 100)) '合格数
    Scz = hg
    
End Function

Public Sub 启动word() '2, 启动word
    On Error Resume Next
    ' 连接至 Word 应用程序
    Set wD = GetObject(, "word.Application")
    If Err Then
        Err.Clear
        Set wD = CreateObject("word.Application")
        If Err Then
            MsgBox Err.Description
            Exit Sub
        End If
    End If
    wD.Visible = True
    wD.ShowMe

End Sub

Public Sub 关闭word()
    On Error Resume Next
    Set wD = GetObject(, "Word.Application")
    If (wD Is Nothing) Then
        Exit Sub
    Else
        PromptToSaveAndClose
        wD.Quit
        Set wD = Nothing
        If Err Then
            Exit Sub
        End If
    End If
End Sub

Sub NewDoc() '新建文档
    Dim docNew As Document
    Set docNew = Documents.Add
    With docNew
        .Content.Font.Name = "Tahoma"
        .SaveAs FileName:="Sample.doc"
    End With
End Sub

Public Sub OpenDocument(wDoc As String)  '3, 打开文件
    'Set wdoc = Documents.Add(新建)
    'ActiveDocument.SaveAs text1.Text(保存)
    ActivateOrOpenDocument wDoc
    'Documents.Open FileName:=App.Path & "\GD.Doc"
    'Set wdoc = Documents.Open(FileName:=App.Path & "\GD.Doc") '(打开指定文件)
End Sub

Sub ActivateOrOpenDocument(wDoc As String) '确定文档是否已打开
    启动word
    Dim doc As Document
    Dim docFound As Boolean

    For Each doc In Documents
        If InStr(1, wDoc, doc.Name, 1) Then
            MsgBox "文件已打开！", , "提示"
            doc.Activate
            docFound = True
            Exit For
        Else
            docFound = False
        End If
    Next doc

    If docFound = False Then Documents.Open FileName:=wDoc
End Sub

Sub SaveDocument() '保存现有文档
    Documents("Sales.doc").Save
End Sub
Sub SaveAllOpenDocuments()
    Documents.Save
End Sub

Sub SaveNewDocument(wDoc As String) '保存新文档
    ActiveDocument.SaveAs FileName:=wDoc
End Sub

'关闭文档
Sub CloseDocument() '若要关闭一篇文档，可使用 Document 对象的 Close 方法。下列指令关闭并保存名为 Sales.doc 的文档。
    Documents("Sales.doc").Close SaveChanges:=wdSaveChanges
End Sub
Sub CloseAllDocuments() '通过应用 Documents 集合的 Close 方法可关闭所有打开的文档。下列指令在不保存更改的情况下关闭所有的文档。
    Documents.Close SaveChanges:=wdDoNotSaveChanges
End Sub
Sub PromptToSaveAndClose() '下列示例在文档关闭以前提示用户保存文档?
    On Error Resume Next
    Dim doc As Document
    For Each doc In Documents
        If Err Then
            'MsgBox Err.Description
            Exit Sub
        End If
        doc.Close SaveChanges:=wdPromptToSaveChanges
    Next
End Sub

Sub ActivateDocument() '激活文档
    Documents("Sales.doc").Activate
End Sub

Public Sub 插入文本() '4，插入文本
    Dim myselection As Word.Selection
    Set myselection = ActiveDocuments.Application.Selection
    '注意上面的这两行代码，只要有这两行代码，就能使用所有的word中的宏操作。以下的代码就是从宏中拷过来的。
    
    With myselection
        .InsertAfter "胡国刚" & vbCrLf
        .Font.Name = "楷体_gb2312"
        .Font.Size = 16
        .ParagraphFormat.Alignment = 1
    End With
    '这里有必要提到宏（macro）在word编程的重要性，几乎所有的word操作，只要你能够通过word能实现，就能编程实现
End Sub

Public Sub 插入图像() '5，插入图像
    Documents.Application.Selection.InlineShapes.AddPicture App.Path & "\Zg.jpg"

End Sub

Public Sub 插入表格() '6，插入表格
    '因为excel中处理表格的能力要比word的处理能力要强，所以能在excel中生成了表格之后再复制到word当中

End Sub

Public Sub Edit_Sheet()
    Set tabx = wD.ActiveDocument.Tables(1)
    tabx.Cell(8, 10).Range.Text = "胡国刚,"
    'oCell.Range.InsertAfter "第 " & iCount & "单元格"
    wD.Visible = True
    wD.ShowMe
    Set wD = Nothing

End Sub

Sub Example() '
    Dim docNew As Document
    Set docNew = wD.Documents.Add '在文档的开头插入一张 3 行 4 列的表格并向每个单元格中添加文字
    Set myTable = wD.ActiveDocument.Tables.Add(Range:=Selection.Range, NumColumns:=5, NumRows:=5)
    iCount = 1
    For Each c In myTable.Range.Cells
        c.Range.InsertAfter "Cell " & iCount
        iCount = iCount + 1
    Next c
    myTable.AutoFormat Format:=wdTableFormatColorful2, ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True '将“彩色型 2”格式的所有属性应用于此表格
    For Each aBorder In ActiveDocument.Sections(1).Borders '给文档中每个表格的首行设置竖线底纹
        With aBorder
                    .ArtStyle = wdArtSeattle
                    .ArtWidth = 20
         End With
    Next aBorder
    
    With myTable '在表格的第一个和最后一个单元格中插入文本
        .Cell(1, 1).Range.InsertAfter "First cell"
        .Cell(myTable.Rows.Count, myTable.Columns.Count).Range.InsertAfter "Last Cell"
    End With
    myTable.Split(BeforeRow:=myTable.Rows(3)).Shading.Texture = wdTexture10Percent '在表格中紧靠指定行的上面插入一空段落，并且返回一个 Table 对象，此对象包含指定行及其下一行。
    ActiveDocument.Tables(1).Cell(1, 1).Split NumColumns:=2 '将第一张表格的第一个单元格拆分为两个单元格
    If Selection.Information(wdWithInTable) = True Then '首先将选定单元格合并为一个再将其拆分为同一行上的三个单元格
        'Selection.Cells.Split NumRows:=1, NumColumns:=3, MergeBeforeSplit:=True
    End If
    If ActiveDocument.Tables.Count >= 1 Then '删除表格中第一行第一列的单元格中的文字
        With ActiveDocument.Tables(1).Cell(row:=1, Column:=1).Range
                                     .Delete
        End With
    End If
    
    ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter '居中对齐活动文档第一张表格的各行
    'ActiveDocument.Tables(1).Rows(1).Delete '删除活动文档中第一张表格的首行
    
End Sub

Public Sub Add_Sheet()
    Dim wD As New Word.Application
    '插入一个3列6行的表格,并给每行表格插入数据
    wD.Documents.Add DocumentType:=wdNewBlankDocument
    Set oDoc = wD.ActiveDocument
    Set oTable = oDoc.Tables.Add(Range:=oDoc.Range(Start:=0, End:=0), NumRows:=6, NumColumns:=3)
    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
    '将光标移到最后
    wD.Selection.EndKey Unit:=wdStory
    '插入分页符
    wD.Selection.InsertBreak Type:=wdPageBreak
    wD.Visible = True
    wD.ShowMe
    Set wD = Nothing

End Sub

Function CheckSpell(IncorrectText As String) As String 'VB中调用Word拼写检查
    Dim Word As Object, retText$
    On Error Resume Next
    '建立对象并打开WORD
    Set Word = CreateObject("Word.Basic")

    '把需要检查的STRING放到WORD
    Word.AppShow
    Word.FileNew
    Word.InsertIncorrectText

    '运行WORD拼写检查
    Word.ToolsSpelling
    Word.EditSelectAll

    '取返回值
    retText = Word.Selection$()
    CheckSpell = Left$(retText, Len(retText) - 1)

    '关闭文件并回到VB应用
    Word.FileClose2
    Word.Show

    Set Word = Nothing
End Function

Public Sub Main()
    启动word
    'OpenDocument
    'MsgBox wd.ActiveDocument.Tables.Count
    'Set myRange = ActiveDocument.Selection.Range
    'ActiveDocument.Tables.Add Range:=myRange, NumRows:=3, NumColumns:=4
    'Example
    '插入文本
    '插入图像
    'Add_Sheet
    'Edit_Sheet
    '关闭word
    'Exit Sub
    
    'Dim wd As Object
    'Dim tp As String
    'Set wd = CreateObject("Word.Basic")
    'wd.FileNewDefault
    'wd.FontSize 20
    'wd.Insert "Hello,World"
    'tp = CheckSpell("Hello,World")
    'wd.FileSaveAs "e:\Hello.Doc"
    'wd.FileClose
    'Set wd = Nothing

End Sub