根据数据表中数据,生成Powerpoint幻灯片

曾经有一个问题，一直困扰我很久。由于工作的需要，经常需要把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