導(dǎo)入導(dǎo)出Word之實(shí)例

todaynew

Private Sub 導(dǎo)入題庫_Click()
Dim doc As New Word.Application
Dim myname As String
Dim str As String
Dim i As Long, m As Long
Dim rs As New ADODB.Recordset
Dim sql As String
Dim n As String, p As Boolean, q As Long
On Error GoTo err_錯(cuò)誤
sql = "select * from 題庫子表"
rs.Open sql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
myname = GetFolder
doc.Documents.Open FileName:=myname
doc.Visible = True
doc.Activate
doc.Documents(myname).Activate
m = doc.Documents(myname).Paragraphs.Count
For i = 2 To m
    doc.Documents(myname).Paragraphs(i).Range.Select
    str = doc.Selection.Text
    p = InStr(str, "一、判斷題") > 0
    p = p Or InStr(str, "二、填空題") > 0
    p = p Or InStr(str, "三、選擇題") > 0
    p = p Or InStr(str, "四、簡(jiǎn)答題") > 0
    If p = True Then
        If InStr(str, "一、判斷題") > 0 Then q = 1
        If InStr(str, "二、填空題") > 0 Then q = 2
        If InStr(str, "三、選擇題") > 0 Then q = 3
        If InStr(str, "四、簡(jiǎn)答題") > 0 Then q = 4
    Else
        doc.Selection.Find.Execute FindText:="題目：", Forward:=True
        If doc.Selection.Text = "題目：" Then
            n = "題目："
            doc.Documents(myname).Paragraphs(i).Range.Select
            rs.AddNew
            rs("題庫ID") = 1
            rs("題型ID") = q
            rs("題目") = str
            If InStr(str, "題目：鏈接：") > 0 Then
            doc.Selection.Copy
            rs("鏈接") = "請(qǐng)通過復(fù)制拷貝方式鏈接題目！"
            End If
            
            rs.Update
        Else
            doc.Selection.Find.Execute FindText:="答案：", Forward:=True
            If doc.Selection.Text = "答案：" Then
                n = "答案："
                rs("答案") = str
                rs.Update
            Else
                If n = "題目：" Then
                    rs("題目") = rs("題目") & Chr(10) & str
                    rs.Update
                Else
                    rs("答案") = rs("答案") & Chr(10) & str
                    rs.Update
                End If
            End If
        End If
    End If
Next
Me.題庫子窗體.Requery
Me.編輯子窗體.Requery
Set doc = Nothing
rs.Close
Exit_退出:
Exit Sub
err_錯(cuò)誤:
    doc.Quit
    MsgBox "出現(xiàn)操作錯(cuò)誤，請(qǐng)檢查。"
Resume Exit_退出:
End Sub

Private Sub 導(dǎo)出試卷_Click()
Dim myname As String
Dim myfolder As String
Dim x As Boolean
Dim myFSO As New FileSystemObject
Dim doc As New Word.Application
Dim i As Long, j As Long, m As Long
Dim myID As Long
Dim strsql As String
Dim rs1 As New ADODB.Recordset
Dim sql1 As String
Dim rs2 As New ADODB.Recordset
Dim sql2 As String
On Error GoTo err_錯(cuò)誤
sql1 = "select * from 題型表"
rs1.Open sql1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    '---------------------------------------------------
    '建立或打開WORD文件
    doc.Visible = True
    myname = InputBox("請(qǐng)輸入試卷名稱：") & ".doc"
    myfolder = CurrentProject.Path & "\試卷\"
    x = myFSO.FileExists(myfolder & myname)
    If Not (x) Then
        doc.Documents.Add
        doc.Activate
        doc.ActiveDocument.SaveAs FileName:=myfolder & myname
    Else
        doc.Documents.Open FileName:=myfolder & myname
        doc.Activate
    End If
   
    '----------------------------------------------------
    '導(dǎo)出ACCESS數(shù)據(jù)
   
    doc.Selection.WholeStory                             '全選
    doc.Selection.Delete Unit:=wdCharacter, Count:=1     '刪除
    doc.Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
    doc.Selection.TypeText Text:="試卷名稱：" & myname
    doc.Selection.TypeParagraph
    doc.Selection.TypeParagraph
    '導(dǎo)出題目
    For i = 1 To rs1.RecordCount
        sql2 = "select * from 題庫子表 where 選中=yes and 題型ID=" & rs1("題型ID")
        rs2.Open sql2, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
            doc.Selection.TypeText Text:=i & "、" & rs1("題型名稱")
            doc.Selection.TypeParagraph
        For j = 1 To rs2.RecordCount
            doc.Selection.TypeText Text:="（" & j & "）"
            If IsNull(rs2("鏈接")) = True Then
                doc.Selection.TypeText Text:=Mid(rs2("題目"), 4)
            Else
                doc.Selection.Font.Color = wdColorRed
                doc.Selection.TypeText Text:="提示：該題有鏈接內(nèi)容，請(qǐng)手工導(dǎo)入。"
                doc.Selection.Font.Color = wdColorAutomatic
            End If
            doc.Selection.TypeParagraph
            rs2.MoveNext
        Next
    rs2.Close
    rs1.MoveNext
    Next
   
    '導(dǎo)出答案
    doc.Selection.TypeParagraph
    doc.Selection.TypeParagraph
    doc.Selection.TypeText Text:="試卷答案："
    doc.Selection.TypeParagraph
    rs1.MoveFirst
    For i = 1 To rs1.RecordCount
        sql2 = "select * from 題庫子表 where 選中=yes and 題型ID=" & rs1("題型ID")
        rs2.Open sql2, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
            doc.Selection.TypeText Text:=i & "、" & rs1("題型名稱")
            doc.Selection.TypeParagraph
        For j = 1 To rs2.RecordCount
            doc.Selection.TypeText Text:="（" & j & "）"
            If IsNull(rs2("鏈接")) = True Then
                doc.Selection.TypeText Text:=Mid(rs2("答案"), 4)
            Else
                doc.Selection.Font.Color = wdColorRed
                doc.Selection.TypeText Text:="提示：該題有鏈接內(nèi)容，請(qǐng)手工導(dǎo)入。"
                doc.Selection.Font.Color = wdColorAutomatic
            End If
            doc.Selection.TypeParagraph
            rs2.MoveNext
        Next
    rs2.Close
    rs1.MoveNext
    Next
   
    doc.Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _
        wdAlignPageNumberCenter, FirstPage:=True           '設(shè)置頁碼
    doc.Documents.Save                                     '保存
'取消題庫表選中標(biāo)識(shí)
strsql = "UPDATE 題庫子表 SET 題庫子表.選中 = no  "
strsql = strsql & "WHERE (((題庫子表.選中)=Yes));"
CurrentDb.Execute strsql

Set doc = Nothing
Set myFSO = Nothing
Set myFile = Nothing
Exit_退出:
Exit Sub
err_錯(cuò)誤:
    doc.Quit
    MsgBox "出現(xiàn)操作錯(cuò)誤，請(qǐng)檢查。"
Resume Exit_退出:
End Sub

koutx

謝謝分享

風(fēng)嘯嘯

謝謝共享，下載學(xué)習(xí)。

5988143

支持原創(chuàng)作品~真的不錯(cuò)~

asklove

大哥，我點(diǎn)導(dǎo)入，彈出WORD窗口，導(dǎo)入三、四行就出現(xiàn)“出現(xiàn)操作錯(cuò)誤，請(qǐng)檢查”！怎么回事啊
還有想請(qǐng)教：有沒有將圖片導(dǎo)入WORD指定位置的例子，謝謝

todaynew

支持原創(chuàng)作品~真的不錯(cuò)~
5988143 發(fā)表于 2009-7-27 20:00

謝謝版主支持

todaynew

大哥，我點(diǎn)導(dǎo)入，彈出WORD窗口，導(dǎo)入三、四行就出現(xiàn)“出現(xiàn)操作錯(cuò)誤，請(qǐng)檢查”！怎么回事啊
還有想請(qǐng)教：有沒有將圖片導(dǎo)入WORD指定位置的例子，謝謝
asklove 發(fā)表于 2009-7-28 10:05

我測(cè)試時(shí)沒有出現(xiàn)問題，呵呵。你可以把錯(cuò)誤處理的語句都屏蔽掉，然后看看是那句出錯(cuò)了。

導(dǎo)入圖片和導(dǎo)入文字應(yīng)該差不多，似乎只是需要從圖片控件讀取數(shù)據(jù)，然后導(dǎo)入到word文檔指定位置就可以了，不過具體尚未作過。

rjacky

謝謝分享

坡芽歌書

謝謝分享

asklove

錯(cuò)誤信息:  方法'Find'作用于對(duì)象'Selection'時(shí)失敗
停在：　  doc.Selection.Find.Execute FindText:="題目：", Forward:=True
難倒是引用上的問題？好像沒有丟失什么的？郁悶