Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
MichD
Bonjour,
Voici un exemple de code créé par Stephen Bullen
Pour l'exécution de ce type de code, tu dois ajouter les bibliothèques suivantes : Microsoft PowerPoint xx Objects library Microsoft Graph xx objects library
Espérons que cela peut aider ton inspiration... ;-) '----------------------------------------------- Sub PPTGenerateSalarySummary()
'Powerpoint objects Dim pptApp As PowerPoint.Application Dim pptPres As PowerPoint.Presentation Dim pptSlide As PowerPoint.Slide Dim pptBullets As PowerPoint.Shape
'MSGraph objects Dim gphChart As Graph.Chart Dim gphData As Graph.DataSheet
'Excel objects Dim pfDiv As Excel.PivotField Dim rngDiv As Excel.Range
'Other variables Dim sBulletText As String Dim lDiv As Long
On Error GoTo ErrorHandler
'Start PowerPoint Set pptApp = CreateObject("PowerPoint.Application")
'Switch back to Excel AppActivate Application.Caption
'Open the presentation Set pptPres = pptApp.Presentations.Open(Filename:=ThisWorkbook.Path & "Salary Presentation.ppt", withwindow:úlse)
'Get the 'Detail' slide Set pptSlide = pptPres.Slides("sldDetail")
'Get the shape containing the bulleted list Set pptBullets = pptSlide.Shapes("shpBullets")
'Get the text of the first bullet in the list sBulletText = pptBullets.TextFrame.TextRange.Paragraphs(1).Text
'Update the text with the calculated total from the worksheet sBulletText = Replace(sBulletText, "#SalaryTotal#", wksData.Range("ptrSalaryTotal").Text)
'Update the presentation with the correct text pptBullets.TextFrame.TextRange.Paragraphs(1).Text = sBulletText
'Get the MSGraph Chart object embedded in the slide Set gphChart = pptSlide.Shapes("shpChart").OLEFormat.Object
'Get the graph's data sheet Set gphData = gphChart.Application.DataSheet
'Get the 'Division' pivot field in the Data worksheet Set pfDiv = wksData.PivotTables(1).PivotFields("Division")
'Loop through the range of Divisions in the pivot table For Each rngDiv In pfDiv.DataRange lDiv = lDiv + 1
'Write the division name and total salary to the graph data sheet gphData.Cells(1, lDiv + 1).Value = rngDiv.Text gphData.Cells(2, lDiv + 1).Value = rngDiv.Offset(0, 1).Value Next rngDiv
'Apply the datasheet changes gphChart.Application.Update
'Redraw the chart object gphChart.Refresh
'Save the presentation with a new name pptPres.SaveAs ThisWorkbook.Path & "Salaries 2003.ppt"
'Tidy up object variables Set pptSlide = Nothing Set pptBullets = Nothing Set gphChart = Nothing Set gphData = Nothing
'Close the presentation pptPres.Close Set pptPres = Nothing
'Close PowerPoint pptApp.Quit Set pptApp = Nothing
'Display the error number and error description ' and note the routine in the title bar MsgBox "Error " & Err.Number & vbLf & Err.Description, _ vbCritical, "Routine: PPTGenerateSalarySummary"
End Sub '-----------------------------------------------
Pour l'exécution de ce type de code, tu dois ajouter
les bibliothèques suivantes :
Microsoft PowerPoint xx Objects library
Microsoft Graph xx objects library
Espérons que cela peut aider ton inspiration... ;-)
'-----------------------------------------------
Sub PPTGenerateSalarySummary()
'Powerpoint objects
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptBullets As PowerPoint.Shape
'MSGraph objects
Dim gphChart As Graph.Chart
Dim gphData As Graph.DataSheet
'Excel objects
Dim pfDiv As Excel.PivotField
Dim rngDiv As Excel.Range
'Other variables
Dim sBulletText As String
Dim lDiv As Long
On Error GoTo ErrorHandler
'Start PowerPoint
Set pptApp = CreateObject("PowerPoint.Application")
'Switch back to Excel
AppActivate Application.Caption
'Open the presentation
Set pptPres = pptApp.Presentations.Open(Filename:=ThisWorkbook.Path &
"Salary Presentation.ppt", withwindow:úlse)
'Get the 'Detail' slide
Set pptSlide = pptPres.Slides("sldDetail")
'Get the shape containing the bulleted list
Set pptBullets = pptSlide.Shapes("shpBullets")
'Get the text of the first bullet in the list
sBulletText = pptBullets.TextFrame.TextRange.Paragraphs(1).Text
'Update the text with the calculated total from the worksheet
sBulletText = Replace(sBulletText, "#SalaryTotal#",
wksData.Range("ptrSalaryTotal").Text)
'Update the presentation with the correct text
pptBullets.TextFrame.TextRange.Paragraphs(1).Text = sBulletText
'Get the MSGraph Chart object embedded in the slide
Set gphChart = pptSlide.Shapes("shpChart").OLEFormat.Object
'Get the graph's data sheet
Set gphData = gphChart.Application.DataSheet
'Get the 'Division' pivot field in the Data worksheet
Set pfDiv = wksData.PivotTables(1).PivotFields("Division")
'Loop through the range of Divisions in the pivot table
For Each rngDiv In pfDiv.DataRange
lDiv = lDiv + 1
'Write the division name and total salary to the graph data sheet
gphData.Cells(1, lDiv + 1).Value = rngDiv.Text
gphData.Cells(2, lDiv + 1).Value = rngDiv.Offset(0, 1).Value
Next rngDiv
'Apply the datasheet changes
gphChart.Application.Update
'Redraw the chart object
gphChart.Refresh
'Save the presentation with a new name
pptPres.SaveAs ThisWorkbook.Path & "Salaries 2003.ppt"
'Tidy up object variables
Set pptSlide = Nothing
Set pptBullets = Nothing
Set gphChart = Nothing
Set gphData = Nothing
'Close the presentation
pptPres.Close
Set pptPres = Nothing
'Close PowerPoint
pptApp.Quit
Set pptApp = Nothing
'Display the error number and error description
' and note the routine in the title bar
MsgBox "Error " & Err.Number & vbLf & Err.Description, _
vbCritical, "Routine: PPTGenerateSalarySummary"
End Sub
'-----------------------------------------------
Pour l'exécution de ce type de code, tu dois ajouter les bibliothèques suivantes : Microsoft PowerPoint xx Objects library Microsoft Graph xx objects library
Espérons que cela peut aider ton inspiration... ;-) '----------------------------------------------- Sub PPTGenerateSalarySummary()
'Powerpoint objects Dim pptApp As PowerPoint.Application Dim pptPres As PowerPoint.Presentation Dim pptSlide As PowerPoint.Slide Dim pptBullets As PowerPoint.Shape
'MSGraph objects Dim gphChart As Graph.Chart Dim gphData As Graph.DataSheet
'Excel objects Dim pfDiv As Excel.PivotField Dim rngDiv As Excel.Range
'Other variables Dim sBulletText As String Dim lDiv As Long
On Error GoTo ErrorHandler
'Start PowerPoint Set pptApp = CreateObject("PowerPoint.Application")
'Switch back to Excel AppActivate Application.Caption
'Open the presentation Set pptPres = pptApp.Presentations.Open(Filename:=ThisWorkbook.Path & "Salary Presentation.ppt", withwindow:úlse)
'Get the 'Detail' slide Set pptSlide = pptPres.Slides("sldDetail")
'Get the shape containing the bulleted list Set pptBullets = pptSlide.Shapes("shpBullets")
'Get the text of the first bullet in the list sBulletText = pptBullets.TextFrame.TextRange.Paragraphs(1).Text
'Update the text with the calculated total from the worksheet sBulletText = Replace(sBulletText, "#SalaryTotal#", wksData.Range("ptrSalaryTotal").Text)
'Update the presentation with the correct text pptBullets.TextFrame.TextRange.Paragraphs(1).Text = sBulletText
'Get the MSGraph Chart object embedded in the slide Set gphChart = pptSlide.Shapes("shpChart").OLEFormat.Object
'Get the graph's data sheet Set gphData = gphChart.Application.DataSheet
'Get the 'Division' pivot field in the Data worksheet Set pfDiv = wksData.PivotTables(1).PivotFields("Division")
'Loop through the range of Divisions in the pivot table For Each rngDiv In pfDiv.DataRange lDiv = lDiv + 1
'Write the division name and total salary to the graph data sheet gphData.Cells(1, lDiv + 1).Value = rngDiv.Text gphData.Cells(2, lDiv + 1).Value = rngDiv.Offset(0, 1).Value Next rngDiv
'Apply the datasheet changes gphChart.Application.Update
'Redraw the chart object gphChart.Refresh
'Save the presentation with a new name pptPres.SaveAs ThisWorkbook.Path & "Salaries 2003.ppt"
'Tidy up object variables Set pptSlide = Nothing Set pptBullets = Nothing Set gphChart = Nothing Set gphData = Nothing
'Close the presentation pptPres.Close Set pptPres = Nothing
'Close PowerPoint pptApp.Quit Set pptApp = Nothing
'Display the error number and error description ' and note the routine in the title bar MsgBox "Error " & Err.Number & vbLf & Err.Description, _ vbCritical, "Routine: PPTGenerateSalarySummary"
End Sub '-----------------------------------------------
