Office中国论坛/Access中国论坛

标题: 导入导出Word之实例 [打印本页]

作者: todaynew 时间: 2009-7-27 16:50
标题: 导入导出Word之实例
本帖最后由 todaynew 于 2009-7-27 17:29 编辑

[attach]39036[/attach]
[attach]39037[/attach]
[attach]39038[/attach]
[attach]39039[/attach]

[attach]39040[/attach]

Private Sub 导入题库_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_错误
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, "四、简答题") > 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, "四、简答题") > 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("链接") = "请通过复制拷贝方式链接题目！"
         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_错误:
doc.Quit
MsgBox "出现操作错误，请检查。"
Resume Exit_退出:
End Sub

Private Sub 导出试卷_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_错误
sql1 = "select * from 题型表"
rs1.Open sql1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

'---------------------------------------------------
'建立或打开WORD文件
doc.Visible = True
myname = InputBox("请输入试卷名称：") & ".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

'----------------------------------------------------
'导出ACCESS数据

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
'导出题目
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:="提示：该题有链接内容，请手工导入。"
            doc.Selection.Font.Color = wdColorAutomatic
         End If
         doc.Selection.TypeParagraph
         rs2.MoveNext
      Next
rs2.Close
rs1.MoveNext
Next

'导出答案
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:="提示：该题有链接内容，请手工导入。"
            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          '设置页码
doc.Documents.Save                                  '保存
'取消题库表选中标识
strsql = "UPDATE 题库子表 SET 题库子表.选中 = no  "
strsql = strsql & "WHERE (((题库子表.选中)=Yes));"
CurrentDb.Execute strsql

Set doc = Nothing
Set myFSO = Nothing
Set myFile = Nothing
Exit_退出:
Exit Sub
err_错误:
doc.Quit
MsgBox "出现操作错误，请检查。"
Resume Exit_退出:
End Sub

作者: koutx 时间: 2009-7-27 17:17
谢谢分享

作者: 风啸啸 时间: 2009-7-27 19:12
谢谢共享，下载学习。

作者: 5988143 时间: 2009-7-27 20:00
支持原创作品~真的不错~

作者: asklove 时间: 2009-7-28 10:05
大哥，我点导入，弹出WORD窗口，导入三、四行就出现“出现操作错误，请检查”！怎么回事啊
还有想请教：有没有将图片导入WORD指定位置的例子，谢谢

作者: todaynew 时间: 2009-7-28 15:20

支持原创作品~真的不错~
5988143 发表于 2009-7-27 20:00

谢谢版主支持

作者: todaynew 时间: 2009-7-28 15:23

大哥，我点导入，弹出WORD窗口，导入三、四行就出现“出现操作错误，请检查”！怎么回事啊
还有想请教：有没有将图片导入WORD指定位置的例子，谢谢
asklove 发表于 2009-7-28 10:05

我测试时没有出现问题，呵呵。你可以把错误处理的语句都屏蔽掉，然后看看是那句出错了。

导入图片和导入文字应该差不多，似乎只是需要从图片控件读取数据，然后导入到word文档指定位置就可以了，不过具体尚未作过。

作者: rjacky 时间: 2009-7-28 15:24
谢谢分享

作者: 坡芽歌书 时间: 2009-7-28 15:57
谢谢分享

作者: asklove 时间: 2009-7-28 16:22
错误信息: 方法'Find'作用于对象'Selection'时失败
停在：　 doc.Selection.Find.Execute FindText:="题目：", Forward:=True
难倒是引用上的问题？好像没有丢失什么的？郁闷

作者: todaynew 时间: 2009-7-28 18:12

错误信息: 方法'Find'作用于对象'Selection'时失败
停在：　 doc.Selection.Find.Execute FindText:="题目：", Forward:=True
难倒是引用上的问题？好像没有丢失什么的？郁闷
asklove 发表于 2009-7-28 16:22

可能是引用的问题。

关于图片导入word的问题，给你做了一个实例，看看是否对你有帮助。

[attach]39047[/attach]

Private Sub Form_Load()
Dim strsql As String
strsql = "UPDATE 图片表 SET 图片表.图片地址 = CurrentProject.Path & '\图片\' & 图片表.图片名称 & '.jpg';"
DoCmd.SetWarnings False
DoCmd.RunSQL strsql
Me.图片.Picture = ""
End Sub

Private Sub 导出_Click()
Dim doc As New Word.Application
Dim myname As String
myname = GetFolder
doc.Documents.Open FileName:=myname
doc.Visible = True
doc.Documents(myname).Activate
x = doc.Documents(myname).Paragraphs.Count
doc.Documents(myname).Paragraphs(x).Range.Select
doc.Selection.TypeParagraph
doc.Selection.InlineShapes.AddPicture FileName:=Me.图片地址.Value, _
LinkToFile:=False, SaveWithDocument:=True
End Sub

Private Sub 图片ID_AfterUpdate()
Me.图片地址.Value = DLookup("图片地址", "图片表", "图片ID=" & Me.图片ID)
Me.图片.Picture = Me.图片地址.Value
End Sub

作者: asklove 时间: 2009-7-29 08:11
非常感谢　todaynew ！！
下载慢慢啃

作者: todaynew 时间: 2009-7-30 08:36

错误信息: 方法'Find'作用于对象'Selection'时失败
停在：　 doc.Selection.Find.Execute FindText:="题目：", Forward:=True
难倒是引用上的问题？好像没有丢失什么的？郁闷
asklove 发表于 2009-7-28 16:22

也可以用instr（doc.Selection.Text ，“题目：”）〉0作为判断条件。

作者: wxf2008hz 时间: 2009-7-31 11:44
不错啊值得学习啊

作者: aaccess 时间: 2009-8-2 11:16
都说好，咱也学习学习

作者: ycxchen 时间: 2009-8-2 12:34
谢谢共享，下载学习。

作者: df 时间: 2009-8-3 19:41
谢谢分享

作者: 8820stboy 时间: 2009-8-4 01:03
谢谢老师

作者: todaynew 时间: 2009-8-4 10:56
谢谢楼上的同志们支持。

作者: herry2003aa 时间: 2009-8-4 18:57
好东西

作者: lymin 时间: 2009-8-7 00:00
收下了

作者: ilovshevchenko 时间: 2009-8-21 20:57
这个好~

作者: yanwei82123300 时间: 2009-8-22 08:27
没赶上，沙发，赶紧支持一下，老师的有一篇大作

作者: ynjxw 时间: 2009-8-22 12:06
太好了，一直就是想要一个这样的例子。
有一问题想问请教一下todaynew。可以导入WORD表格里的数据吗？

作者: todaynew 时间: 2009-8-26 08:08

太好了，一直就是想要一个这样的例子。
有一问题想问请教一下todaynew。可以导入WORD表格里的数据吗？
ynjxw 发表于 2009-8-22 12:06

应该可以，不过最近有些忙。周末给你回复。

作者: ynjxw 时间: 2009-8-26 14:17
谢谢todaynew，就等你的解决办法了。

作者: 86814898 时间: 2009-10-22 14:42
谢谢了

作者: c101 时间: 2009-10-25 11:26
谢谢分享

作者: wansong2008 时间: 2009-12-9 16:10
Thank you for sharing

作者: cashiba 时间: 2009-12-12 02:35
好资料谢谢了

作者: leijiqiang 时间: 2010-1-11 08:45
这个家伙精品太多

作者: lovelaceliu 时间: 2010-3-11 21:54
很好很强大

作者: zyz218 时间: 2010-11-26 23:47
又学习了一把

作者: littlekey 时间: 2010-11-27 09:11
太经典了。

作者: 快乐王 时间: 2010-12-12 22:11
回复 todaynew 的帖子

todaynew 老师，您太强大了。

作者: myua2k 时间: 2010-12-15 01:39
谢谢共享，下载学习。

作者: 13601812106_01 时间: 2010-12-15 12:38
牛人

作者: cumtclmk123 时间: 2015-5-21 22:57
真不错

作者: 至少还有你 时间: 2015-5-24 11:33
新手看看

作者: nncchh 时间: 2015-5-25 23:08
谢谢分享

作者: 玉树TMD临风 时间: 2015-6-9 20:32
老大，你这个刚才和我今天想要导入的一个模板很象，就是有个小小的问题。

在问题中，有这样的“请听些段语音：20150605.wav文件”，其中，20150605.wav文件双击可以播放，请问这个wav文件如何导入到字段，双击时也能播放？OLE可以吗。

作者: xlb004 时间: 2015-12-5 09:49

这个正需要，谢谢

作者: xlb004 时间: 2015-12-5 09:50

这个正需要，谢谢

作者: WFH6898 时间: 2015-12-5 13:25
太厉害了

作者: WFH6898 时间: 2015-12-5 14:13
太强大了

作者: QQ214189912 时间: 2016-7-7 17:56
谢谢分享

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)