在vb中怎样调用word，对word进行操作，并进行打印？

我刚写的一个小工具，是把excel里面的东西导入到word里面，你可以参考。
具体关于打印：调用word.document.printout方法就可以了。贴子太长，必须截掉一块了，没办法。里面用到了通过程序设置文档属性，表格，页楣页脚.域，书签，等等许多东西，应该有参考价值。Option ExplicitPublic gObjExcel As New Excel.Application
Public gObjWord As New Word.ApplicationPublic gWorkbook As New Excel.Workbook
Public gWorksheet As New Excel.Worksheet
Public gDocu As New Word.DocumentDim iStartRow As Integer
Dim iEndRow As Integer
Dim iStartCol As Integer
Dim iProperCheckResult As Integer
Dim iTestItemCheckResult As Integer
Dim strDestFileName As StringPublic iCurrentRow As LongPublic Function GetSourceFileName() As String
    
    Dim iIndex As Long
    Dim iDotPos As Long
    FileDialog.Filter = "All Files (*.*)|*.*|Excel File(*.xls)|*.xls"
    FileDialog.FilterIndex = 2
    FileDialog.ShowOpen
    GetSourceFileName = FileDialog.FileName
    
    If FileDialog.FileName <> "" Then
        
        iIndex = InStr(1, FileDialog.FileName, "\")
        iDotPos = InStr(1, FileDialog.FileName, ".")
        
        Do
        iIndex = InStr(iIndex + 1, FileDialog.FileName, "\")
        Loop Until iIndex = 0
        
        strDestFileName = Left(FileDialog.FileName, iIndex) & Mid(FileDialog.FileName, iIndex + 1, iDotPos - iIndex - 1)
        strDestFileName = strDestFileName & ".doc"
        txtDestFilePath.Text = strDestFileName
        
    End If
    
End Function
Private Sub cmdSrcOpen_Click()
On Error GoTo ErrorHandle
    Dim strTmp As String
    strTmp = GetSourceFileName()    If strTmp <> "" Then
        txtSourceFilePath.Text = strTmp
        cmdStartConvert.Enabled = True
    Else
        txtSourceFilePath.Text = ""
        MsgBox "Please chose Source file"
    End If
    
    Exit Sub
ErrorHandle:
    txtSourceFilePath.Text = ""
    MsgBox "Exception Occur!"
End SubPrivate Sub cmdStartConvert_Click()
On Error GoTo ErrorHandle    cmdSrcOpen.Enabled = False
    cmdStartConvert.Enabled = False    Dim iRet As Long
        
    picProgress.Visible = True
    Call DrawStatus("Prepare to open source excel file...", 3)
    Set gWorkbook = gObjExcel.Workbooks.Open(txtSourceFilePath.Text)
    Call DrawStatus("Source excel file open sucess", 6)
    
    
    If Dir(txtDestFilePath.Text) <> "" Then
        Call Kill(txtDestFilePath.Text)
    End If
    
    
    Call DrawStatus("Prepare to copy Template file...", 9)
    Call FileCopy(App.Path + "\PT_Template.doc", txtDestFilePath.Text)
    Call DrawStatus("Copy Template success", 11)
    
    Call DrawStatus("Prepare to open dest word file...", 12)
    Set gDocu = gObjWord.Documents.Open(txtDestFilePath.Text)
    Call DrawStatus("Dest word file open sucess", 15)
    
    gObjWord.Visible = False
    gObjExcel.Visible = False
    gObjWord.DisplayScreenTips = False
    
    Call DrawStatus("Prepare to check source excel file check...", 16)
    iRet = fncItemCheckResult()
    If iRet <> 0 Then
        GoTo ErrorHandle
    End If
    Call DrawStatus("Check source excel file success", 18)
    
    fncItemsProduct
    
    Call DrawStatus("Make all of test items success", 90)
    
    Call DrawStatus("Prepare to set document property", 91)
    Call subSetDocProperty
    Call DrawStatus("Set document's property success", 92)
    
    Call DrawStatus("Prepare to set test program list", 93)
    fncSetTestObjectList
    Call DrawStatus("Set test program list success", 94)
    
    
    Call DrawStatus("Prepare to set pagefoot", 95)
    fncSetPageFoot
    Call DrawStatus("Set pagefoot success", 96)    
    Call DrawStatus("Prepare to save word document", 97)
    
    gDocu.Save    
    Call DrawStatus("Save word document success", 98)
    
    Call DrawStatus("Prepare to close word and excel objects", 99)
    
    
    gDocu.Close
    gWorkbook.Close Savechanges:=False
    
    Call DrawStatus("Close word and excel objects success ", 100)
    
    cmdSrcOpen.Enabled = True
    cmdStartConvert.Enabled = True
    
    picProgress.Visible = False
    frmMain.AutoRedraw = True
    frmMain.Cls
    frmMain.AutoRedraw = False
    MsgBox "convertting has been finished!", vbInformation, "ETOW Tip"
    
    Exit Sub
ErrorHandle:
    gDocu.Close Savechanges:=False
    gWorkbook.Close Savechanges:=FalseEnd SubPrivate Sub Form_Unload(Cancel As Integer)
    gObjWord.Quit
    gObjExcel.Quit
    
    Set gObjExcel = Nothing
    Set gObjWord = Nothing
    Set gDocu = Nothing
    Set gWorkbook = Nothing
    Set gWorksheet = Nothing
End Sub
Private Function fncInsertNewRow()
On Error GoTo ErrorHandle    Dim iTableCount As Long
    Dim iRange As Word.Range
    Dim index0 As Long
    
    iTableCount = ActiveDocument.Tables.Count
    index0 = ActiveDocument.Tables(iTableCount).Rows.Count    ActiveDocument.Tables(iTableCount).Rows(index0).Select
    ActiveDocument.Application.Selection.InsertRowsBelow 1
    
    fncInsertNewRow = True
    Exit Function
ErrorHandle:
    fncInsertNewRow = False
End FunctionPrivate Function fncMidItemStart(strMidItemName As String) As Boolean
On Error GoTo ErrorHandle
    Dim iTableCount As Long
    Dim iRange As Word.Range
    Dim index0 As Long
    
    iTableCount = ActiveDocument.Tables.Count
    index0 = ActiveDocument.Tables(iTableCount).Rows.Count
    ActiveDocument.Tables(iTableCount).Rows(index0).Range.Cells(1).Range.Text = strMidItemName    fncMidItemStart = True
    Exit Function
ErrorHandle:
    fncMidItemStart = False
End FunctionPrivate Function fncMidItemMerge() As Boolean
On Error GoTo ErrorHandle
    
    Dim iTableIndex As Long
    Dim iRowIndex As Long
    
    For iTableIndex = 2 To ActiveDocument.Tables.Count
        
        iRowIndex = 5
        
        While iRowIndex <= ActiveDocument.Tables(iTableIndex).Rows.Count
            
            If Mid(ActiveDocument.Tables(iTableIndex).Rows(iRowIndex).Cells(1).Range.Text, 2, 1) = "" Then
                ActiveDocument.Tables(iTableIndex).Rows(iRowIndex).Cells(1).Borders(wdBorderTop).LineStyle = wdLineStyleNone
            End If
            iRowIndex = iRowIndex + 1
        Wend
        
    Next    fncMidItemMerge = True
    Exit Function
ErrorHandle:
    fncMidItemMerge = False
    MsgBox Err.Description
End Function

解决方案 »

  1.   

    Private Function fncBigItemStart(strBigItemName As String) As Boolean
    On Error GoTo ErrorHandle
        Dim iIndex As Long
        Dim iTableCount As Long
        Dim iRange As Word.Range
        Dim index0 As Long
        Dim strItemName As String
        
        Dim iPos As Long
        
        iTableCount = ActiveDocument.Tables.Count
        index0 = ActiveDocument.Tables(iTableCount).Rows.Count
        
        strItemName = strBigItemName
        
        If LenB(strItemName) < 5 Then
            strItemName = strItemName & String(7 - LenB(strItemName), " ")
        End If
        
        If Not (iTableCount = 2 And index0 = 4) Then
            ActiveDocument.Tables(2).Rows(1).Select
            ActiveDocument.Application.Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
            ActiveDocument.Application.Selection.Copy
        
            Set iRange = ActiveDocument.Tables(iTableCount).Rows.Last.Range
            iRange.Cells(12).Select
            ActiveDocument.Application.Selection.MoveRight Unit:=wdCharacter, Count:=2
            ActiveDocument.Application.Selection.InsertBreak Type:=wdPageBreak
            ActiveDocument.Application.Selection.Paste
        End If
            iTableCount = ActiveDocument.Tables.Count
            ActiveDocument.Tables(iTableCount).Rows(2).Range.Cells(1).Range.Text = "<" & strItemName & ">"
            ActiveDocument.Tables(iTableCount).Rows(4).Range.Delete Unit:=wdCharacter, Count:=1
        
        fncBigItemStart = True
        Exit Function
    ErrorHandle:
        fncBigItemStart = False
    End FunctionPrivate Function fncItemAppend(strItem As String, N1 As Integer, N2 As Integer, N3 As Integer, iType As Integer, _
    strDesctrip As String, strPaper As String, strHigh As String, strNG As String, strManDate As String, strMemo As String) As Boolean
    On Error GoTo ErrorHandle
        Dim iTableCount As Long
        Dim index0 As Long
        Dim iRange As Word.Range
        
        iTableCount = ActiveDocument.Tables.Count
        index0 = ActiveDocument.Tables(iTableCount).Rows.Count
        Set iRange = ActiveDocument.Tables(iTableCount).Rows(index0).Range
        iRange.Cells(2).Range.Text = strItem
        iRange.Cells(3).Range.Text = N1
        iRange.Cells(4).Range.Text = N2
        iRange.Cells(5).Range.Text = N3
        iRange.Cells(6).Range.Text = iType
        iRange.Cells(7).Range.Text = strDesctrip
        iRange.Cells(8).Range.Text = strPaper
        iRange.Cells(9).Range.Text = strHigh
        iRange.Cells(10).Range.Text = strNG
        iRange.Cells(11).Range.Text = strManDate
        iRange.Cells(12).Range.Text = strMemo
        
        fncItemAppend = True
        Exit Function
    ErrorHandle:
        fncItemAppend = False
    End FunctionPrivate Sub subSetDocProperty()
    On Error GoTo ErrorHandle    Set gWorksheet = gWorkbook.Worksheets("愝掕")    Dim dp As Object
        Set dp = ActiveDocument.BuiltinDocumentProperties
        dp(wdPropertyTitle) = gWorksheet.Cells(6, 4).Value & " 揳 " & gWorksheet.Cells(7, 4).Value
        dp(wdPropertySubject) = gWorksheet.Cells(8, 4).Value
        dp(wdPropertyCompany) = gWorksheet.Cells(11, 4).Value
        dp(wdPropertyKeywords) = gWorksheet.Cells(13, 4).Value
        dp(wdPropertyAuthor) = gWorksheet.Cells(12, 4).Value
        ActiveDocument.Fields.Update    Dim tmpRange As Word.Range
        Dim iStartPos As Long
        iStartPos = ActiveDocument.Books("JGDVERSIONBK").Start
        Set tmpRange = ActiveDocument.Range(Start:=iStartPos, End:=iStartPos + 19)
        Dim strVersion As String
        Dim strMakeDate As String
        
        strVersion = CStr(gWorksheet.Cells(9, 4).Value)
        strMakeDate = CStr(gWorksheet.Cells(10, 4).Value)
        tmpRange.Text = "戞" & strVersion & "斉  " & strMakeDate
        ActiveDocument.Books("JGDVERSIONBK").Delete
        
        
        iStartPos = ActiveDocument.Books("JGDINDEXBK").Start
        Set tmpRange = ActiveDocument.Range(Start:=iStartPos, End:=iStartPos)
        
        With ActiveDocument
            .TablesOfContents(1).Delete
            .TablesOfContents.Add Range:=tmpRange, RightAlignPageNumbers:= _
                True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
                LowerHeadingLevel:=6, IncludePageNumbers:=True, AddedStyles:="", _
                UseHyperlinks:=True, HidePageNumbersInWeb:=True
            .TablesOfContents(1).TabLeader = wdTabLeaderDots
            .TablesOfContents.Format = wdIndexIndent
        End With
        
        ActiveDocument.Books("JGDINDEXBK").Delete
        
        Exit Sub
    ErrorHandle:End SubPrivate Function fncItemCheckResult() As Long
    On Error GoTo ErrorHandle    Set gWorksheet = gWorkbook.Worksheets("愝掕")    iStartRow = gWorksheet.Cells(128, 5).Value
        iStartCol = gWorksheet.Cells(129, 5).Value
        iEndRow = gWorksheet.Cells(130, 5).Value
        iProperCheckResult = gWorksheet.Cells(131, 5).Value
        iTestItemCheckResult = gWorksheet.Cells(132, 5).Value
        If iEndRow = -1 Then
            MsgBox "Not find  Any test Items,Please check excel file"
            fncItemCheckResult = -1
            Exit Function
        End If
        If (iProperCheckResult <> 0) Or (iTestItemCheckResult <> 0) Then
            MsgBox "Please Check it In Excel,then Do Word document"
            fncItemCheckResult = -2
            Exit Function
        End If
            
        fncItemCheckResult = 0
        Exit Function
    ErrorHandle:End Function
      

  2.   

    Private Function fncItemsProduct() As Long
    On Error GoTo ErrorHandle
        Set gWorksheet = gWorkbook.Worksheets("帋閯崁栚")
        Dim iRowIndex As Long
        Dim iProgressStartPos As Long    Dim strItem As String
        Dim N1 As Integer
        Dim N2 As Integer
        Dim N3 As Integer
        Dim iType As Integer
        Dim strDesctrip As String
        Dim strPaper As String
        Dim strHigh As String
        Dim strNG As String
        Dim strManDate As String
        Dim strMemo As String
        Dim bMiddleIsStart As Boolean
        Dim bBigIsStart As Boolean
        Dim iTableCount As Long
        Dim index0 As Long
        
        Call DrawStatus("Prepare to make test item...", 16)
        
        iProgressStartPos = g_CurrentProgress
        
        For iRowIndex = iStartRow To iEndRow
            DoEvents
        
            Call DrawStatus("Making test item " & CStr(iRowIndex - iStartRow + 1) & "/" & CStr(iEndRow - iStartRow + 1), iProgressStartPos + CLng(73 * (iRowIndex - iStartRow + 1) / (iEndRow - iStartRow + 1)))
        
            If gWorksheet.Cells(iRowIndex, iStartCol - 2).Value <> "" Then
               fncBigItemStart (CStr(gWorksheet.Cells(iRowIndex, iStartCol - 2).Value))
               bBigIsStart = True
            Else
               bBigIsStart = False
            End If
            
            If gWorksheet.Cells(iRowIndex, iStartCol - 1).Value <> "" Then
                If bBigIsStart <> True Then
                    fncInsertNewRow
                End If
            
                fncMidItemStart (CStr(gWorksheet.Cells(iRowIndex, iStartCol - 1).Value))
                bMiddleIsStart = True
            Else
                bMiddleIsStart = False
            End If
            
            If bMiddleIsStart <> True Then
                fncInsertNewRow
            End If
            
            strItem = gWorksheet.Cells(iRowIndex, iStartCol).Value
            N1 = gWorksheet.Cells(iRowIndex, iStartCol + 1).Value
            N2 = gWorksheet.Cells(iRowIndex, iStartCol + 2).Value
            N3 = gWorksheet.Cells(iRowIndex, iStartCol + 3).Value
            iType = gWorksheet.Cells(iRowIndex, iStartCol + 4).Value
            strDesctrip = gWorksheet.Cells(iRowIndex, iStartCol + 5).Value
            strPaper = gWorksheet.Cells(iRowIndex, iStartCol + 6).Value
            strHigh = gWorksheet.Cells(iRowIndex, iStartCol + 7).Value
            strNG = gWorksheet.Cells(iRowIndex, iStartCol + 8).Value
            strManDate = gWorksheet.Cells(iRowIndex, iStartCol + 9).Value
            strMemo = gWorksheet.Cells(iRowIndex, iStartCol + 10).Value
            fncItemAppend strItem, N1, N2, N3, iType, strDesctrip, strPaper, strHigh, strNG, strManDate, strMemo
        Next    
        Call DrawStatus("Merging middle Items,it may be cost a long time please wait... ", g_CurrentProgress)
        fncMidItemMerge
        
        
        Exit Function
    ErrorHandle:
        MsgBox Err.DescriptionEnd Function
    Private Function fncSetTestObjectList() As Long
    On Error GoTo ErrorHandle    Dim iCount As Long
        Set gWorksheet = gWorkbook.Worksheets("愝掕")
        
        Dim usrTestList As typTestObjectList
        
        For iCount = 1 To 7
            usrTestList.TestProgram(iCount).strProgram = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + iCount, TESTLIST_EXCEL_START_COL).Value
            usrTestList.TestProgram(iCount).strMediaNo = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + iCount, TESTLIST_EXCEL_START_COL + 3).Value
            usrTestList.TestProgram(iCount).strVersion = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + iCount, TESTLIST_EXCEL_START_COL + 5).Value
        Next
        
        usrTestList.strHardWare = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 9, TESTLIST_EXCEL_START_COL).Value
        usrTestList.strMemo = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 28, TESTLIST_EXCEL_START_COL).Value
        usrTestList.strLineNumTotal = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 35, TESTLIST_EXCEL_START_COL + 1).Value
        usrTestList.strLineNumNew = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 37, TESTLIST_EXCEL_START_COL).Value
        usrTestList.strLineNumOld = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 37, TESTLIST_EXCEL_START_COL + 1).Value
        usrTestList.strLineNumModify = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 37, TESTLIST_EXCEL_START_COL + 2).Value
        usrTestList.strItemNumBig = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 37, TESTLIST_EXCEL_START_COL + 3).Value
        usrTestList.strItemNumMiddle = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 37, TESTLIST_EXCEL_START_COL + 4).Value
        usrTestList.strItemNumSmall = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 37, TESTLIST_EXCEL_START_COL + 5).Value
        usrTestList.strTestMen = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 39, TESTLIST_EXCEL_START_COL).Value
        usrTestList.strTestDate = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 39, TESTLIST_EXCEL_START_COL + 3).Value
        usrTestList.strTestArea = gWorksheet.Cells(TESTLIST_EXCEL_START_ROW + 41, TESTLIST_EXCEL_START_COL).Value
        
        For iCount = 1 To 7
            ActiveDocument.Tables(1).Rows(iCount + 1).Cells(1).Range.Text = usrTestList.TestProgram(iCount).strProgram
            ActiveDocument.Tables(1).Rows(iCount + 1).Cells(2).Range.Text = usrTestList.TestProgram(iCount).strMediaNo
            ActiveDocument.Tables(1).Rows(iCount + 1).Cells(3).Range.Text = usrTestList.TestProgram(iCount).strVersion
        Next
            
            
        ActiveDocument.Tables(1).Rows(10).Range.Words(1).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strHardWare
        
        ActiveDocument.Tables(1).Rows(12).Range.Words(1).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strMemo
        
        ActiveDocument.Tables(1).Rows(15).Cells(1).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strLineNumTotal
        
        ActiveDocument.Tables(1).Rows(15).Cells(2).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strLineNumNew    ActiveDocument.Tables(1).Rows(15).Cells(3).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strLineNumOld    ActiveDocument.Tables(1).Rows(15).Cells(4).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strLineNumModify    ActiveDocument.Tables(1).Rows(15).Cells(5).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strItemNumBig    ActiveDocument.Tables(1).Rows(15).Cells(6).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strItemNumMiddle    ActiveDocument.Tables(1).Rows(15).Cells(7).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strItemNumSmall    ActiveDocument.Tables(1).Rows(17).Cells(1).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strTestMen    ActiveDocument.Tables(1).Rows(17).Cells(2).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strTestDate    ActiveDocument.Tables(1).Rows(19).Select
        ActiveDocument.Application.Selection.Text = usrTestList.strTestArea    Exit Function
    ErrorHandle:End Function
    Private Function fncSetPageFoot() As Long
    On Error GoTo ErrorHandle
        Dim strItemTypeName(1 To 10) As String
        Dim iCount As Long
        Dim strFoot As String
        
        Set gWorksheet = gWorkbook.Worksheets("愝掕")
        
        For iCount = 1 To 10
            strItemTypeName(iCount) = gWorksheet.Cells(TYPE_START_ROW + iCount, TYPE_START_COL).Value
        Next
        
        strFoot = ""
        
        For iCount = 1 To 10
            strFoot = strFoot & "  " & strItemTypeName(iCount)
        Next    ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).Range.Sentences(9).Text = "JL-7.3-08丂丂丂丂丂丂懨No.(懨摉惈娤揰斣崋)"
        ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).Range.Sentences(10).Text = ""
        ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).Range.Sentences(10).Text = "Tmp"
        ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).Range.Sentences(10) = strFoot    Exit Function
    ErrorHandle:End Function