[VBA] PowerPoint grafiek vullen met data uit MS Access tabel - Client software algemeen

dinsdag 5 februari 2008 11:41

Acties:

Topicstarter

Voor een standaard rapportage wil ik een set grafieken in een powerpoint presentatie vullen met data uit access tabellen.

Nu heb ik een stuk VBA code gevonden waarmee ik de data die in een Access tabel staat direct in de tabel van een grafiekobject in een slide van een powerpointpresentatie kan zetten. Dit werkt prima en heb ik werkend; alleen wil ik nu in 1 run een hele set aan grafieken met verschillende tabellen vullen. En de code die ik nu heb doet er dus maar 1:
ACC2000: How to Create an MS Graph in PowerPoint Using Access

Hierbij heb je 3 parameters die ingevoerd moeten worden:

Visual Basic:

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

- De locatie waar de powerpoint wordt opgeslagen
- De access tabel waar de data in staat
- Optioneel een 'template' presentatie (die ik dus gebruik) waar de grafieken in gevuld worden

De bijkomende uitdaging wordt dat ik op 1 slide 2 grafieken kan hebben, dus moet ik ook nog het juiste grafiek object zien te selecteren.

De orignele code heb ik 'gestript' tot het volgende en dat is nog werkend:

Visual Basic:

Option Explicit
Option Compare Database


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

   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.

      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 these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.
         Set OpwrPresent = _
         OPwrPnt.Presentations.Open(CGFF_SavedPPT).Slides(2)
         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.


      On Error GoTo ERR_CGFF


         ' 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
         CreateGraphPPT = True
         GoTo Exit_CGFF


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!!!"
     CreateGraphPPT = 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"
   CreateGraphPPT = False

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

End Function

Als ik nu een 2e slide wil vullen, moet ik volgens mij dit stuk 'herhalen' (waarschijnlijk kan dit makkelijker/ mooier, maar ik zou niet weten hoe)

Visual Basic:

         
         
               
        Set CGFF_DB = Nothing
        Set CGFF_Rs = Nothing
        Set OpwrPresent = Nothing
      
        Set CGFF_DB = CurrentDb
        Set CGFF_Rs = CGFF_DB.OpenRecordset("Table2", dbOpenSnapshot)
      
      
        ' Use these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.
         Set OpwrPresent = _
         OPwrPnt.Presentations.Open(CGFF_SavedPPT).Slides(3)
         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.

      On Error GoTo ERR_CGFF
         ' 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

Als ik dit stuk tussenvoeg, krijg ik geen error, maar het probleem is nu dat hij opnieuw de template oppakt en niet gewoon naar de volgende slide gaat. Hoe verander ik de volgende code (waar het volgens mij in zit) zodat hij het stukje Open() niet nodig heeft?:

Visual Basic:

1 2	Set OpwrPresent = _ OPwrPnt.Presentations.Open(CGFF_SavedPPT).Slides(3)

Andere vraag is dus hoe ik een 2e grafiekobject kan selecteren in 1 slide en dan die kan vullen met data? Volgens mij zit dat in de volgende code:

Visual Basic:

         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

Een specialist weet veel van weinig en leert steeds meer van steeds minder, tot hij uiteindelijk alles weet van niets.

dinsdag 5 februari 2008 16:44

Acties:

apophis4u

Topicstarter

Ok, inmiddels heb ik het 'werkend'.

Volgens mij kan alles alleen nog wel een stuk efficienter gecodeerd of weggeschreven worden. Voornamelijk de 'search object' functie voor het vinden van een grafiek vind ik wat gevaarlijk; ik snap namelijk niet waar ik voor het 1e grafiek object de count functie moet gebruiken en bij het 2e object wel gewoon hard het objectnummer kan invoeren:

Visual Basic:

1	For Shpcnt = 1 To OpwrPresent.Shapes.Count

Grafiek 1:

Visual Basic:

1	OpwrPresent.Shapes(Shpcnt)

Grafiek 2 in dezelfde slide:

Visual Basic:

1	OpwrPresent.Shapes(2)

Verder kan het stuk 'tussen de ****' gekopieerd en hergebruikt worden om een volgend grafiekobject in dezelfde slide of op een andere slide te vullen. Volgens mij moet dit dan ook met een soort van loop functie kunnen waarbij je dan eerder de tabellen met slide & grafieknummers kunt definieren.

Als iemand daar nog bij kan helpen?

Visual Basic:

Option Explicit
Option Compare Database

Function CreateGraphPPT() As Boolean

   On Error GoTo ERR_CGFF
   Dim CGFF_PPTFileName As String, CGFF_Tablename As String, CGFF_SavedPPT As String
   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

   CGFF_PPTFileName = "C:\Documents and Settings\h.degooijer\Desktop\test.ppt"
   CGFF_SavedPPT = "C:\Documents and Settings\h.degooijer\Desktop\LevenTemplate.ppt"
   
      ' 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
      

'*******************************************************************************
    
    CGFF_Tablename = "TBL S02 MedeKL"
        
      Set CGFF_DB = CurrentDb
      Set CGFF_Rs = CGFF_DB.OpenRecordset(CGFF_Tablename, dbOpenSnapshot)
      On Error GoTo ERR_CGFF

         ' Use these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.
         Set OpwrPresent = _
         OPwrPnt.Presentations.Open(CGFF_SavedPPT).Slides(2)
         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.

      On Error GoTo ERR_CGFF


         ' 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



' *******************************************************************************

         
    CGFF_Tablename = "TBL S02 Keten"



        Set CGFF_DB = CurrentDb
        Set CGFF_Rs = CGFF_DB.OpenRecordset(CGFF_Tablename, dbOpenSnapshot)
      
        ' Use these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.

         Set OpwrPresent = _
         OPwrPnt.ActivePresentation.Slides(2)
         FndGraph = False

         For Shpcnt = 2 To OpwrPresent.Shapes.Count

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

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

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

         ' If a graph was found.

      On Error GoTo ERR_CGFF
         ' 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
         CreateGraphPPT = True
         GoTo Exit_CGFF



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!!!"
     CreateGraphPPT = 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"
   CreateGraphPPT = False

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

End Function

Een specialist weet veel van weinig en leert steeds meer van steeds minder, tot hij uiteindelijk alles weet van niets.

dinsdag 5 februari 2008 20:48

Acties:

Bolukan

De code om op de sheet te zoeken, is omdat de sheet ook andere objecten kan bevatten dan graphs. Als jij shapes(2) gebruikt, kan dat omdat je precies weet (controleert) dat er verder geen objecten op de sheet staan. Dan zou ik de hele zoekfunctie verwijderen.

Verder adviseer ik de functie te splitsen in een gedeelte dat het bestand opent en weer sluit en daar tussen een functie plaatsen die met opgave van sheet-nummer, shape-nummer, brongegevens (CGFF_Tablename) de graph update. Dat maakt je macro veel schaalbaarder en minder redundantie van code.
Daarvoor voeg je een variabele toe als verwijzing naar het bestand, de variabele geef je mee aan je tweede functie samen met het slidenr, shapenr, etc.

Visual Basic:

1
2
3

Dim OPwrPntPres As Object
Set OPwrPntPres = OPwrPnt.Presentations.Open(CGFF_SavedPPT)
MaakEenGraph OPwePntPres, SlideNr:=1, ShapeNr:=1, TableName:="table2"

Visual Basic:

1
2
3

Private Sub MaakEenGraph etc etc
Set OpwrPresent = OPwrPntPres.Slides(SlideNr)
Set shpGraph = OpwrPresent.Shapes(ShapeNr).OLEFormat.Object

Dan volg je met regel 63 tm 102 van je orginele code en de rest (saven bestand) staat weer in de hoofdfunctie.

Succes.

donderdag 7 februari 2008 15:33

Acties:

apophis4u

Topicstarter

Super bedankt voor de input, ik heb het nu voor elkaar met onderstaande functie om met 1 regel de volgende grafiek op de volgende slide te vullen.

Ik ben er in ieder geval achter dat ik erg weinig controle heb over de 'shapes' op een slide en dit wil ik dus toch laten bepalen door de shapecount functie.
Hiervoor wil ik een extra parameter gaan meegeven in de vorm van een 2e tabelnaam (die ik leeg kan laten) waarmee hij gaat zoeken naar het vólgende grafiekobject. Ik heb alleen geen idee hoe ik de shapecount (shpCnt) functie hierop kan aanpassen, zou je me hier bij kunnen helpen?

Visual Basic:

Option Explicit
Option Compare Database


Function CreateGraphPPT() As Boolean

   On Error GoTo ERR_CGFF
   Dim CGFF_PPTFileName As String, CGFF_Tablename As String, CGFF_SavedPPT As String
   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, OPwrPntPres 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
   
   CGFF_PPTFileName = CurrentProject.Path & "\Kadaster Standaard analysesTEST.ppt"
     
      ' 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
      CGFF_SavedPPT = CurrentProject.Path & "\Template\Kadaster analyses.ppt"
      
      OPwrPnt.Presentations.Open (CGFF_SavedPPT)

FillGraph OPwrPnt, "6", "TBL Output Laatste 12 maanden - Labels - Marktaandelen"
FillGraph OPwrPnt, "7", "TBL Output Laatste 12 maanden - Holdings - Marktaandelen"
FillGraph OPwrPnt, "8", "TBL Output Laatste 12 maanden - Strategische groepen - Marktaand"
FillGraph OPwrPnt, "9", "TBL Output Laatste 12 maanden - Marktomvang"

       
         ' Release the references and save the slide.
         
         OPwrPnt.ActivePresentation.SaveAs (CGFF_PPTFileName)
         DoEvents
         'OPwrPnt.Quit
         CreateGraphPPT = True
         GoTo Exit_CGFF

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!!!"
     CreateGraphPPT = 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"
   CreateGraphPPT = False

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

End Function


Function FillGraph(OPwrPnt As Object, SlideNr As Integer, TableName As String)
       
   Dim CGFF_PPTFileName As String, CGFF_SavedPPT As String
   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 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
  
      Set CGFF_DB = CurrentDb
      Set CGFF_Rs = CGFF_DB.OpenRecordset(TableName, dbOpenSnapshot)
      


         ' Use these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.
         Set OpwrPresent = _
         OPwrPnt.ActivePresentation.Slides(SlideNr)
                  
         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

         ' 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

End Function

[ Voor 14% gewijzigd door apophis4u op 07-02-2008 15:51 ]

Een specialist weet veel van weinig en leert steeds meer van steeds minder, tot hij uiteindelijk alles weet van niets.

donderdag 7 februari 2008 19:35

Acties:

Bolukan

Geef op regel 74 een volgnummer mee
Regel 97 tm 113 levert nu de laatste shape op die voldoet aan het criterium. Je moet met het volgnummer de zoektocht laten stoppen bij het volgnummer van de gevonden shape die je wilt wijzigen.

Bijvoorbeeld rond 106-110:
if volgnummer > 0 then
regel 106-110
end if
volgnummer = volgnummer - 1
Een beetje slordig programmeren, maar het werkt.

PS: Probeer na regel 105 eens een debug.print OpwrPresent.Shapes(Shpcnt).name of iets dergelijks. Dat kan helpen om te achterhalen wat er allemaal op zo'n sheet is te vinden.

[ Voor 20% gewijzigd door Bolukan op 07-02-2008 19:38 ]

woensdag 13 februari 2008 13:13

Acties:

apophis4u

Topicstarter

Kun je me hier een stuk voorbeeld code van geven, want ik kom helemaal nergens op uit.

Verder heb ik nog een ander probleem, ik wil voor het controleren dat de grafiek de juiste data krijgt ook de grafiektitel instellen vanuit mijn VB code. Echter stelt hij deze titels op beide grafiek objecten in, in plaats van alleen op het 'gevonden' grafiek object:

Visual Basic:

1	shpGraph.ChartTitle.Text = GraphTitle

Visual Basic:

Option Explicit
Option Compare Database

Function CreateGraphPPT() As Boolean

   On Error GoTo ERR_CGFF
   Dim CGFF_PPTFileName As String, CGFF_Tablename As String, CGFF_SavedPPT As String, FileName As String
   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, OPwrPntPres 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
   
    CGFF_PPTFileName = CurrentProject.Path & "\POtest.ppt"
    CGFF_SavedPPT = CurrentProject.Path & "\testpos.ppt"
    
      ' 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

      
      OPwrPnt.Presentations.Open (CGFF_SavedPPT)

FillGraph OPwrPnt, "16", 1, "Omvang van het kantoor", "TBL S02 MedeKL"
FillGraph OPwrPnt, "16", 2, "onderdeel van keten", "TBL S02 Keten"




         ' Release the references and save the slide.
         
         OPwrPnt.ActivePresentation.SaveAs (CGFF_PPTFileName)
         DoEvents
         'OPwrPnt.Quit
         CreateGraphPPT = True
         GoTo Exit_CGFF

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!!!"
     CreateGraphPPT = 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"
   CreateGraphPPT = False

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

End Function


Function FillGraph(OPwrPnt As Object, SlideNr As Integer, ObjectNr As Integer, GraphTitle As String, TableName As String)
       
   Dim CGFF_PPTFileName As String, CGFF_SavedPPT As String
   Dim oDataSheet As Object
   Dim shpGraph As Object, Shpcnt As Integer, ShpNr As Integer, FndGraph As Boolean
   Dim lRowCnt, lColCnt, lValue As Long, CGFF_FldCnt As Integer
   Dim 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
  
      Set CGFF_DB = CurrentDb
      Set CGFF_Rs = CGFF_DB.OpenRecordset(TableName, dbOpenSnapshot)
      


         ' Use these lines if you already have a saved chart
         ' on a PowerPoint
         ' slide.
         Set OpwrPresent = _
         OPwrPnt.ActivePresentation.Slides(SlideNr)
         
         If (ObjectNr = 1) Then
         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
                  
                  shpGraph.ChartTitle.Text = GraphTitle
                  ' Found the graph.
                  FndGraph = True
                  
                                 
               End If
            End If
         Next Shpcnt
         End If
         
         If (ObjectNr = 2) Then

         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
                shpGraph.ChartTitle.Text = GraphTitle
                ' Found the graph.
                FndGraph = True
                End If

                                 
            End If
         Next Shpcnt
         End If
         
         
         ' 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

End Function

Een specialist weet veel van weinig en leert steeds meer van steeds minder, tot hij uiteindelijk alles weet van niets.

woensdag 13 februari 2008 15:32

Acties:

apophis4u

Topicstarter

ok, volgende workaround:

Met onderstaande code kun je namelijk het grafiekobject een naam geven:

Visual Basic:

 Sub NameIt()

  Dim sResponse As String

  With ActiveWindow.Selection.ShapeRange(1)
    sResponse = InputBox("new name ...", "Rename Shape", .Name)
    Select Case sResponse
     ' blank names not allowed
     Case Is = ""
       Exit Sub
     ' no change?
     Case Is = .Name
       Exit Sub
     Case Else
       On Error Resume Next
       .Name = sResponse
       If Err.Number <> 0 Then
         MsgBox "Unable to rename this shape"
       End If
    End Select
  End With

End Sub

Bron:
http://www.databaselesson...me-powerpoint-objects.php

Daarmee kan ik dus mooi gericht schieten op de grafiekobjecten in mijn template bestand

YEUY!!

Volgende wat dan erg neat zou zijn, maar vraag me af of het mogelijk is; is om alleen de grafiek te definiëren zonder dat ik daar een slidenummer bij hoef aan te geven.
Is deze mogelijkheid er in VBA voor PowerPoint of is PPT zo 'narrowminded' dat objecten per slide zijn toegewezen en er dus niet door alle slides te zoeken is?

Een specialist weet veel van weinig en leert steeds meer van steeds minder, tot hij uiteindelijk alles weet van niets.

donderdag 14 februari 2008 09:23

Acties:

Bolukan

Nee, shapes zijn onderdeel van de slide. Als je met de naam een shape wilt vinden, kun je natuurlijk de slides doorlopen en daarbinnen de shapes om deze ene shape te vinden.

Bij het vullen van de datasheet loop je alle velden door (For Each CGFF_Field etc), maar bij het vullen van de data gebruik je Fields(CGFF_FldCnt - 1) in plaats van CGFF_Field. Dat is onlogisch, omdat je daarvoor juist For Each CGFF_Field hebt gebruikt.

Ik zie ook niet in wat ObjectNr 1 en 2 er toe doen. Ik geef hieronder een voorbeeld hoe je de shapes kunt tellen, misschien was dat de bedoeling.

Code-aanpassingen zijn ongetest.

Visual Basic:

Option Explicit
Option Compare Database

Function CreateGraphPPT() As Boolean

Dim OPwrPnt As Object            ' Reference to Powerpoint Application
Dim CGFF_PwrPntloaded As Boolean ' Is Powerpoint Application loaded

Dim OPwrPresent As Object        ' Reference to PowerPoint.Presentation
Dim CGFF_SavedPPT As String      ' Filename to open in Powerpoint (no saving, see next line)
Dim CGFF_PPTFileName As String   ' Filename to save as after update graphs

 On Error GoTo ERR_CGFF
   
 CGFF_PPTFileName = CurrentProject.Path & "\POtest.ppt"
 CGFF_SavedPPT = CurrentProject.Path & "\testpos.ppt"
    
 ' 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

 Set OPwrPresent = OPwrPnt.Presentations.Open(CGFF_SavedPPT)

 FillGraph OPwrPresent, 16, 1, "Omvang van het kantoor", "TBL S02 MedeKL"
 FillGraph OPwrPresent, 16, 2, "onderdeel van keten", "TBL S02 Keten"

 ' Release the references and save the slide.
 OPwrPresent.SaveAs CGFF_PPTFileName
 DoEvents
 'OPwrPnt.Quit
 CreateGraphPPT = True
 GoTo Exit_CGFF

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!!!"
 CreateGraphPPT = 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"
 CreateGraphPPT = False

Exit_CGFF:
 Set OPwrPnt = Nothing
 Set OPwrPresent = Nothing
 
End Function

Function FillGraph(OPwrPresent As Object, SlideNr As Integer, ShapeNr As Integer, GraphTitle As String, _
                   TableName As String)
      
Dim CGFF_DB As DAO.Database
Dim CGFF_TD As DAO.TableDef
Dim CGFF_Rs As DAO.Recordset
Dim CGFF_field As DAO.Field

Dim OPwrSlide As Object             ' Reference to PowerPoint.Slide
Dim ShpNr As Integer                ' Counter for shapes in slide
Dim shpGraph As Object              ' Reference to Graph
Dim FndGraph As Boolean             ' Found graph
Dim oDataSheet As Object            ' Datasheet of Graph
Dim lRowCnt As Integer
Dim CGFF_FldCnt As Integer
  
 ' Use these lines if you already have a saved chart on a PowerPoint slide.
 Set OPwrSlide = OPwrPresent.Slides(SlideNr)
 
 ' Find the graph on slide (Wait for no ShapeNr)
 For ShpNr = 1 To OPwrSlide.Shapes.Count
    ' Check if shape is an OLE object.
    If OPwrSlide.Shapes(ShpNr).Type = 7 Then
       ' Check if OLE object is graph 9 object. The ProgID is case sensitive.
       If OPwrSlide.Shapes(ShpNr).OLEFormat.ProgID = "MSGraph.Chart.8" Then
          ' Wait for next if ShapeNr > 1
          If ShapeNr > 1 Then
             ShapeNr = ShapeNr - 1
          Else
             Set shpGraph = OPwrSlide.Shapes(ShpNr).OLEFormat.Object
             ' Found the graph.
             FndGraph = True
          End If
       End If
    End If
 Next ShpNr
         
 ' Update Graph title
 shpGraph.ChartTitle.Text = GraphTitle
 
 ' Set the reference to the datasheet collection.
 Set oDataSheet = shpGraph.Application.DataSheet
 ' Clear the datasheet.
 oDataSheet.Cells.Clear

 ' Reference to data
 Set CGFF_DB = CurrentDb
 Set CGFF_Rs = CGFF_DB.OpenRecordset(TableName, dbOpenSnapshot)
         
 ' These are the lines to set up you row headings You can make this anything you want.
 CGFF_FldCnt = 0
 ' Loop through the fields collection and get the field names.
 For Each CGFF_field In CGFF_Rs.Fields
    CGFF_FldCnt = CGFF_FldCnt + 1
    oDataSheet.Cells(CGFF_FldCnt, 1).Value = CGFF_field.Name
 Next CGFF_field
 
 lRowCnt = 1
 ' Loop through the recordset.
 Do While Not CGFF_Rs.EOF
    lRowCnt = lRowCnt + 1
    CGFF_FldCnt = 0
    ' Put the values for the fields in the datasheet.
    For Each CGFF_field In CGFF_Rs.Fields
       CGFF_FldCnt = CGFF_FldCnt + 1
       oDataSheet.Cells(CGFF_FldCnt, lRowCnt).Value = CGFF_field.Value
    Next CGFF_field
    CGFF_Rs.MoveNext
 Loop

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

End Function