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

- 中国WEB开发者网络 (http://www.webasp.net)
-- 技术教程 (http://www.webasp.net/article/)
--- 根据数据表中数据,生成Powerpoint幻灯片 (http://www.webasp.net/article/29/28087.htm)
-- 作者:未知
-- 发布日期: 2007-01-08

由于工作的需要,经常需要把Access数据表的内容,制作成powerpoint幻灯片,常常在做大量的单调的重复的简单劳动。作为一个程序设计的爱好者,最不愿意做的就是这种简单机械的事情。第一步:先用Powerpoint新建一张幻灯片,添加五个文本框,分别用 于显示数据表中五个字段的值;再添加其它有关文本,并设置好各对象的格式及动画。 第二步:在Access数据中,建立以下程序:

曾经有一个问题,一直困扰我很久。由于工作的需要,经常需要把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 = "A:" & Trim(rs("xxone")) & Chr(13)
                s4 = s4 & "B:" & Trim(rs("xxtwo")) & Chr(13)
                s4 = s4 & "C:" & Trim(rs("xxthr")) & Chr(13)
                s4 = s4 & "D:" & 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

 


webasp.net