AW: Werte aus Powerpoint charts auslesen
01.04.2010 12:15:35
Heiko
Hallo Chris,
in 2007 so, ob das in 2003 klappt mußt du mal testen.
Sub TabellenAusPP()
Dim intI As Integer
Dim strPfad As String
Dim myFileSystemObject, myFiles
Dim ppApp As Object, ppSlide As Object, ppShapes As Object
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Left(ThisWorkbook.Path, 2) & "\"
.Title = "Ordnerauswahl"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPfad = .SelectedItems(1)
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
Else
MsgBox "Sie haben keinen Ordner ausgewählt, das Makro wird abgebrochen!", _
vbInformation
Exit Sub
End If
End With
On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
If Err = 429 Then Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = True
On Error GoTo 0
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
For Each myFiles In myFileSystemObject.GetFolder(strPfad).Files
If InStr(UCase(myFiles.Name), "PPT") > 0 Then
ppApp.presentations.Open myFiles.Path
For Each ppSlide In ppApp.ActivePresentation.Slides
For Each ppShapes In ppSlide.Shapes
If ppShapes.HasTable Then
ppShapes.Copy
ActiveWorkbook.ActiveSheet.Paste Destination:=ActiveWorkbook.ActiveSheet. _
Cells(ActiveWorkbook.ActiveSheet.Cells(65535, 1).End(xlUp).Row + 2, 1)
End If
Next ppShapes
Next ppSlide
ppApp.ActivePresentation.Save
End If
Next myFiles
ppApp.Quit
Application.ScreenUpdating = True
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !!!