本文来源于悠悠博客 http://www.ajaxstu.com/ , 原文地址：http://www.ajaxstu.com/archives/2399_3B.html

根据数据表中数据,生成Powerpoint幻灯片2006-10-4 9:28:45 发布:Y0uYoU

曾经有一个问题，一直困扰我很久。由于工作的需要，经常需要把Access数据表的内容,制作成powerpoint幻灯片，常常在做大量的单调的重复的简单劳动。作为一个程序设计的爱好者，最不愿意做的就是这种简单机械的事情。
那么，如何根据数据表中数据,生成Powerpoint幻灯片呢？
我的具体要求是这样的:
每个记录 对应一张幻灯片;
每个字段的内容,对应一个文本框;
最好,相同字段对应的文本框,在每张幻灯片中的位置和格式是相同的.
大体过程是这样的：
第一步：先用Powerpoint新建一张幻灯片，添加五个文本框，分别用 于显示数据表中五个字段的值；再添加其它有关文本，并设置好各对象的格式及动画。
第二步：在Access数据中，建立以下程序：
Sub lPPTadd(sTH As String, sYM As String, sLR As String, sXH As String, sDA As String, sTX As String)
'参数分别是: 题号,页码,内容,选项,答案,题型
'使用复制的方法来添加幻灯片
Set newSlide = ActivePresentation.Slides(1).Duplicate
With newSlide
.Shapes("Rectangle 2").TextFrame.TextRange.Text = Trim(sTH) '题号
.Shapes("Rectangle 3").TextFrame.TextRange.Text = Trim(sLR) '内容
.Shapes("Rectangle 6").TextFrame.TextRange.Text = Trim(sYM) '页码
.Shapes("Rectangle 7").TextFrame.TextRange.Text = Trim(sDA) '答案
.Shapes("Text Box 8").TextFrame.TextRange.Text = Trim(sTX) '题型
.Shapes("Rectangle 9").TextFrame.TextRange.Text = Trim(sXH) '选项
End With
End Sub
Sub ReadDb()
Dim s As String
Dim sDB As String
Dim lconn As New ADODB.Connection
Dim rs As New ADODB.Recordset
sDB = "F:\bq1.mdb"
s = " Provider=Microsoft.Jet.OLEDB.4.0 "
s = s & " Data Source= " & Trim(sDB)
s = s & " ;Persist Security Info=False"
lconn.Open s
s = "SELECT * FROM 题库 "
rs.Open s, lconn, adOpenStatic, adLockReadOnly
rs.MoveLast
Dim i As Long, n As Long
Dim s1 As String, s2 As String, s3 As String, s4 As String, s5 As String, s6 As String
n = rs.RecordCount
rs.MoveFirst
i = 1
If n > 0 Then
Call lPPTdel
Do While Not rs.EOF
s1 = Trim(str(i))
n = Val("" & rs("page"))
s2 = IIf(n = 0, "", Trim(str(n)))
s3 = Trim(rs("kttxt"))
n = Val("" & rs("txcode"))
If n = 0 Or n = 1 Then
s4 = "Ａ：" & Trim(rs("xxone")) & Chr(13)
s4 = s4 & "Ｂ：" & Trim(rs("xxtwo")) & Chr(13)
s4 = s4 & "Ｃ：" & Trim(rs("xxthr")) & Chr(13)
s4 = s4 & "Ｄ：" & Trim(rs("xxfou"))
s5 = "（" + IIf(rs("ISOKone") = 1, "A", "")
s5 = s5 & IIf(rs("ISOKtwo") = 1, "B", "")
s5 = s5 & IIf(rs("ISOKthr") = 1, "C", "")
s5 = s5 & IIf(rs("ISOKfou") = 1, "D", "") & "）"
End If
Select Case n
Case 0
s6 = "多选题"
Case 1
s6 = "单选题"
Case 2
s4 = ""
s5 = "（" + IIf(rs("ISOK") = 1, "√", "×") & "）"
s6 = "判断题"
Case Else
s4 = ""
s5 = ""
s6 = ""
End Select
Call lPPTadd(s1, s2, s3, s4, s5, s6)
i = i + 1
rs.MoveNext
Loop
End If
t2 = Timer
MsgBox ("生成结束! 用时 " & str(t2 - t1))
End Sub
Sub lPPTadd(sTH As String, sYM As String, sLR As String, sXH As String, sDA As String, sTX As String)
'参数分别是: 题号,页码,内容,选项,答案,题型
'使用复制的方法来添加幻灯片
Set newSlide = ActivePresentation.Slides(1).Duplicate
For Each s In newSlide.Shapes
Debug.Print s.Id, s.Name, s.TextFrame.TextRange.Text
Next
With newSlide
.Shapes("Rectangle 2").TextFrame.TextRange.Text = Trim(sTH) '题号
.Shapes("Rectangle 3").TextFrame.TextRange.Text = Trim(sLR) '内容
.Shapes("Rectangle 6").TextFrame.TextRange.Text = Trim(sYM) '页码
.Shapes("Rectangle 7").TextFrame.TextRange.Text = Trim(sDA) '答案
.Shapes("Text Box 8").TextFrame.TextRange.Text = Trim(sTX) '题型
.Shapes("Rectangle 9").TextFrame.TextRange.Text = Trim(sXH) '选项
End With
End Sub

原创文章如转载，请注明：转载自悠悠博客 [ http://www.ajaxstu.com/ ]
本文链接地址：http://www.ajaxstu.com/archives/2399_3B.html