在powerpoint中查看图片（在ms access中存储为附件）

Question

我正在尝试在 PowerPoint 演示文稿中展示我的 MS 访问数据。 我正在编写 VBA 代码以根据我的数据创建一个 ppt。 我想在每张幻灯片中找到一张圆形裁剪的照片。 这些照片在 MS access 中保存为附件。

• 这段代码是用在我的桌面上找到的照片填充椭圆形，它工作得很好：

With .Shapes.AddShape(msoShapeOval, 360, 121, 220, 220) 
     .Fill _
     .UserPicture "C:\Users\USER\Desktop\kkk.jpg"
     .Line.Visible = False   'no outline
End With

- 结果如下：

• 但我需要从数据库中挑选这些图片，所以我使用了这段代码，但它给了我“对象 Fillformat 的用户图片失败”：

With .Shapes.AddShape(msoShapeOval, 360, 121, 220, 220) 
     .Fill _
     .UserPicture (CStr(rs.Fields("photo").Value.FileName))
     .Line.Visible = False   'no outline

End With

• 其中“照片”是存储附件的表中的字段

完整代码：

Option Compare Database

Option Explicit

Sub cmdPowerPoint_Click()
    Dim db As Database, rs As Recordset
    Dim ppObj As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation

    On Error GoTo err_cmdOLEPowerPoint

    ' Open up a recordset on the Employees table.
    Set db = CurrentDb
    Set rs = db.OpenRecordset("Employees", dbOpenDynaset)
    
    ' Open up an instance of Powerpoint.
    Set ppObj = New PowerPoint.Application
    Set ppPres = ppObj.Presentations.Add

    ' Setup the set of slides and populate them with data from the
    ' set of records.
    With ppPres
        While Not rs.EOF
            With .Slides.Add(rs.AbsolutePosition + 1, ppLayoutTitle)
                .Shapes(1).TextFrame.TextRange.Text = "Hi!  Page " & rs.AbsolutePosition + 1
                .SlideShowTransition.EntryEffect = ppEffectFade
                With .Shapes(2).TextFrame.TextRange
                    .Text = CStr(rs.Fields("LastName").Value)
                    .Characters.Font.Color.RGB = RGB(255, 0, 255)
                    .Characters.Font.Shadow = True
                End With
                With .Shapes.AddShape(msoShapeOval, 360, 121, 220, 220) 'photo
                     .Fill _
                     .UserPicture (CStr(rs.Fields("photo").Value.FileName))
      
                    .Line.Visible = False   'no outline

                End With
                
                With .Shapes.AddShape(msoShapeOval, 85, 260, 85, 85) 'customer
                     .Fill.ForeColor.RGB = RGB(239, 48, 120)
                     .Line.Visible = False

                End With

                With .Shapes.AddShape(msoShapeOval, 85, 355, 135, 135) 'improvement (down)
                     .Fill.ForeColor.RGB = RGB(0, 176, 240)
                     .Line.Visible = False

                End With



               With .Shapes.AddShape(msoShapeOval, 38, 136, 110, 110) 'staff
                    .Fill.ForeColor.RGB = RGB(238, 149, 36)
                    .Line.Visible = False

               End With

               With .Shapes.AddShape(msoShapeOval, 158, 45, 135, 135) 'improvement (up)
                    .Fill.ForeColor.RGB = RGB(0, 176, 240)
                    .Line.Visible = False

               End With

                With .Shapes.AddShape(msoShapeOval, 193, 206, 135, 135) 'characteristics
                     .Fill.ForeColor.RGB = RGB(238, 149, 36)
                     .Line.Visible = False
                End With
                
                .Shapes(1).TextFrame.TextRange.Characters.Font.Size = 50
            End With
            rs.MoveNext
        Wend
    End With

    ' Run the show.
    ppPres.SlideShowSettings.Run

    Exit Sub

err_cmdOLEPowerPoint:
    MsgBox Err.Number & " " & Err.Description
End Sub

Answer 1

假设图像必须从文件夹位置加载到 PP。 以编程方式从 Access 表附件字段中提取图像是一个常见主题，并且有许多示例可用。 保存到磁盘然后加载到 PP 可能是这样的：

Dim rs As DAO.Recordset, fd As DAO.Field2
Set rs = CurrentDb.OpenRecordset("Employees", dbOpenDynaset)
...
Set fd = rs("photo")
fd("FileData").SaveToFile CurrentProject.path
.Fill.UserPicture CurrentProject.path & "\" & fd("FileName")
Kill CurrentProject.path & "\" & fd("FileName")
...