ACC2000: How to Create an MS Graph in PowerPoint Using Access

Option Explicit
					

Option Compare Database

Function CreateGraphFromFile(CGFF_PPTFileName As String, _
  CGFF_Tablename As String, CGFF_SavedPPT As String) As Boolean

    '********************************************************************
    'Function:  CreateGraphFromFile
    'Purpose:   Create a graph on a PowerPoint Slide using a Microsoft
    '           Access table.
    '
    'Arguments: CGFF_PPTFilename - name of the new PowerPoint presentation
    '           file that you want to create. You must include the file
    '           name and path.
    '
    '           CGFF_Tablename- name of the Microsoft Access table or query
    '
    '           CGFF_SavedPPT - name of a previously saved PowerPoint
    '           presentation with a graph object already on it. An
    '           empty string ("") if you want to use a blank presentation
    '
    '
    'Returns:  True if successful or False if not.
    '
    '****************************************************************

   On Error GoTo ERR_CGFF
   Dim oDataSheet As Object
   Dim shpGraph As Object, Shpcnt As Integer, FndGraph As Boolean
   Dim lRowCnt, lColCnt, lValue As Long, CGFF_FldCnt As Integer
   Dim OPwrPnt As Object, OpwrPresent As Object
   Dim CGFF_DB As DAO.Database, CGFF_TD As DAO.TableDef
   Dim CGFF_Rs As DAO.Recordset, CGFF_field As DAO.Field
   Dim CGFF_PwrPntloaded As Boolean
   Dim lheight, lwidth, LLeft, lTop As Single

   ' See if the CGFF Table already exists.
   If IsTableQuery("", CGFF_Tablename) Then
      Set CGFF_DB = CurrentDb
      Set CGFF_Rs = CGFF_DB.OpenRecordset(CGFF_Tablename, dbOpenSnapshot)
      On Error GoTo ERR_CGFF

      ' Set up the object references.
      On Error GoTo Err_CGFFOle
      CGFF_PwrPntloaded = False
      Set OPwrPnt = CreateObject("Powerpoint.application")

      ' Activate PowerPoint. If you do not want to see PowerPoint,
      ' remark the
      ' next line out.
      OPwrPnt.Activate
      CGFF_PwrPntloaded = True

      ' Use this line to Open a default saved presentation
      ' Set OpwrPresent = OPwrPnt.Presentations.Open(DefFileName).Slides(1)

      If CGFF_SavedPPT = "" Then

         ' Use these lines to create a new Graph object on the slide.
         Set OpwrPresent = OPwrPnt.Presentations.Add.Slides.Add(1, 12)
         lheight = OPwrPnt.ActivePresentation.PageSetup.SlideHeight / 2
         lwidth = OPwrPnt.ActivePresentation.PageSetup.SlideWidth / 2
         LLeft = OPwrPnt.ActivePresentation.PageSetup.SlideHeight / 4
         lTop = OPwrPnt.ActivePresentation.PageSetup.SlideHeight / 4
         Set shpGraph = OpwrPresent.Shapes.AddOLEObject(Left:=LLeft, _
         Top:=lTop, Width:=lwidth, Height:=lheight, _
         ClassName:="MSGraph.Chart", Link:=0).OLEFormat.Object
         FndGraph = True
      Else

         ' Use these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.
         Set OpwrPresent = _
         OPwrPnt.Presentations.Open(CGFF_SavedPPT).Slides(1)
         FndGraph = False
         For Shpcnt = 1 To OpwrPresent.Shapes.Count

            ' Check if shape is an OLE object.
            If OpwrPresent.Shapes(Shpcnt).Type = 7 Then

               ' Check if OLE object is graph 9 object. The ProgID is
               ' case sensitive.
               If OpwrPresent.Shapes(Shpcnt).OLEFormat.ProgId = _
                 "MSGraph.Chart.8" Then
                  Set shpGraph = _
                  OpwrPresent.Shapes(Shpcnt).OLEFormat.Object

                  ' Found the graph.
                  FndGraph = True
               End If
            End If
         Next Shpcnt

         ' If a graph was found.
      End If
      On Error GoTo ERR_CGFF
      If FndGraph Then

         ' Set the reference to the datasheet collection.
         Set oDataSheet = shpGraph.Application.DataSheet

         ' Clear the datasheet.
         oDataSheet.Cells.Clear

         ' These are the lines to set up you row headings You can make this
         ' anything you want.
         CGFF_FldCnt = 1

         ' Loop through the fields collection and get the field names.
         For Each CGFF_field In CGFF_Rs.Fields
            oDataSheet.Cells(CGFF_FldCnt, 1).Value = _
              CGFF_Rs.Fields(CGFF_FldCnt - 1).Name
            CGFF_FldCnt = CGFF_FldCnt + 1
         Next CGFF_field
         lRowCnt = 1

         ' Loop through the recordset.
         Do While Not CGFF_Rs.EOF
            CGFF_FldCnt = 1

            ' Put the values for the fields in the datasheet.
            For Each CGFF_field In CGFF_Rs.Fields
               oDataSheet.Cells(CGFF_FldCnt, lRowCnt + 1).Value = _
                 CGFF_Rs.Fields(CGFF_FldCnt - 1).Value
               CGFF_FldCnt = CGFF_FldCnt + 1
            Next CGFF_field
            lRowCnt = lRowCnt + 1
            CGFF_Rs.MoveNext
         Loop

         ' Update the graph.
         shpGraph.Application.Update
         DoEvents
         CGFF_Rs.Close
         CGFF_DB.Close

         ' Release the references and save the slide.
         OPwrPnt.ActivePresentation.SaveAs (CGFF_PPTFileName)
         DoEvents
         OPwrPnt.Quit
         CreateGraphFromFile = True
         GoTo Exit_CGFF
      Else   ' No graphs were found display an error.
         MsgBox "No graph objects were found on the Activepresentation", _
            vbOKOnly, "No Graphs!!!"
         OPwrPnt.Quit
         CreateGraphFromFile = False
         GoTo Exit_CGFF
      End If
   Else

      ' No table was found.
      MsgBox "There is not a recordset named " & CGFF_Tablename & _
        "In this database", vbOKOnly, "No Table!!!"
      CreateGraphFromFile = False
      Exit Function
   End If

Err_CGFFOle:
   ' OLE error section when trying to communicate with PowerPoint.
   MsgBox "There was a problem Communicating with PowerPoint", vbOKOnly, _
     "No data file!!!"
   MsgBox Err & " " & Err.Description, vbOKOnly, "Data file problem!!!"
     CreateGraphFromFile = False
   If CGFF_PwrPntloaded Then
      OPwrPnt.Quit
   End If
   GoTo Exit_CGFF

ERR_CGFF:
   ' General error section.
   MsgBox Err & " " & Err.Description, vbOKOnly, _
     "An Error has occurred with this application"
   CreateGraphFromFile = False

Exit_CGFF:
   Set oDataSheet = Nothing
   Set OPwrPnt = Nothing
   Set OpwrPresent = Nothing
   Set shpGraph = Nothing

End Function

'********************************************************
' FUNCTION: IsTableQuery()
'
' PURPOSE: Determine if a table or query exists.
'
' ARGUMENTS:
'   DbName: The name of the database. If the database name
'           is "" the current database is used.
'    TName: The name of a table or query.
'
' RETURNS: True (it exists) or False (it does not exist).
'
'********************************************************

Function IsTableQuery(DbName As String, TName As String) As Integer
   Dim Db As Database, Found As Integer, Test As String

   Const NAME_NOT_IN_COLLECTION = 3265

   ' Assume the table or query does not exist.
   Found = False

   ' Trap for any errors.
   On Error Resume Next

   ' If the database name is empty...
   If Trim$(DbName) = "" Then

      '...then set Db to the current Db.
      Set Db = CurrentDb()
   Else
      'Otherwise, set Db to the specified open database.
      Set Db = DBEngine.Workspaces(0).OpenDatabase(DbName)

      'See if an error occurred.
      If Err Then
         MsgBox "Could not find database to open: " & DbName
         IsTableQuery = False
         Exit Function

      End If
   End If

   ' See if the name is in the Tables collection.
   Test = Db.TableDefs(TName).Name
   If Err <> NAME_NOT_IN_COLLECTION Then Found = True

   ' Reset the error variable.
   Err = 0

   ' See if the name is in the Queries collection.
   Test = Db.QueryDefs(TName$).Name
   If Err <> NAME_NOT_IN_COLLECTION Then Found = True
   Db.Close
   IsTableQuery = Found
End Function
					

?CreateGraphFromFile("C:\MyPPT.ppt", "Category Sales for 1997", "")