EXCEL Daten einfügen

 

Home
Nach oben

Last Update 20.07.2004

Copyright  2003
Ramses (C)

.

Tabellenbereich nach Powerpoint exportieren

Diagramm nach Powerpoint exportieren

Verknüpfte Objecte in Powerpoint neu verlinken

 


Exportiert einen definierten Bereich in eine definierte Powerpoint Präsentation auf eine bestimmte Folie

Sub Excel_Range_an_PPT()
    Dim ppApp As Object
    Dim ppFile As Object
    Dim ppPres As String
    Dim picObj As Object, picName As String
    'Dateiname
    ppPres = "C:\Demo.ppt"
    'Object referenzieren
    Set ppApp = CreateObject("Powerpoint.Application")
    'Bereich kopieren
    Worksheets("Tabelle1").Range("A1:E6").Copy
    'Object initialisieren
    ppApp.Visible = msoTrue
    'PPT öffnen
    Set ppFile = ppApp.Presentations.Open(ppPres)
    'Foliennummer angeben
    ppApp.ActivePresentation.Slides(1).Select
    'Bereich einfügen und OLE Verknüpfung herstellen = Link
    With ppApp.ActiveWindow
        .ViewType = ppViewSlide
        .View.PasteSpecial DataType:=ppPasteDefault, link:=msoTrue
    End With
    'Eingefügte Tabelle skalieren
    With ppApp.ActiveWindow.Selection.ShapeRange
        'Oberer Rand 1 cm unter Standardtitel
        .Top = 150
        'Linker Rand 1.5 cm von linkem Folienrand
        .Left = 35
        'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
        .Width = 650
        'Bei Bedarf Höhe noch einstellen
        'Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
        'Die Breite verändert sich dann
        '.Height = 300
    End With
End Sub
 

Zurück


 


Ein Chart in eine Powerpoint Präsentation exportieren und einfügen

Sub Excel_Chart_an_PPT()
    Dim ppApp As Object
    Dim ppFile As Object
    Dim ppPres As String
    'Dateiname
    ppPres = "C:\Demo.ppt"
    'Object referenzieren
    Set ppApp = CreateObject("Powerpoint.Application")
    'Diagramm kopieren : Name bitte anpassen
    ActiveSheet.ChartObjects("Diagramm 1").Chart.ChartArea.Copy
    'Object initialisieren
    ppApp.Visible = msoTrue
    'PPT öffnen
    Set ppFile = ppApp.Presentations.Open(ppPres)
    'Foliennummer angeben
    ppApp.ActivePresentation.Slides(1).Select
    'Bereich einfügen und OLE Verknüpfung herstellen = Link
    With ppApp.ActiveWindow
        .ViewType = ppViewSlide
        .View.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
    End With
    'Eingefügtes Diagramm skalieren
    With ppApp.ActiveWindow.Selection.ShapeRange
        'Oberer Rand 1 cm unter Standardtitel
        .Top = 150
        'Linker Rand 1.5 cm von linkem Folienrand
        .Left = 35
        'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
        .Width = 650
        'Bei Bedarf Höhe noch einstellen
        'Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
        'Die Breite verändert sich dann
        '.Height = 300
    End With
End Sub
 

Zurück


 

 Aktualisiert Links von eingebetten Objection in einer Powerpoint Präsentation

Die Anforderung entstand aus dem Auftrag, dass eine Tabelle in welcher die Unternehmensdaten monatlich hinzugefügt und erweitert werden, mit einer PowerPoint-Präsentation verknüpft werden.

Diese EXCEL Tabelle wird aber monatlich unter einem neuen Namen gespeichert, woraus das Problem resultiert, dass die Präsentation jedesmal neu erstellt werden muss weil die Object Links immer noch auf die alte EXCEL Tabelle verweisen. Mit diesem Makro werden die bisherigen Object-Links in der Präsentation auf die, unter einem anderen Namen gespeicherte VATER-Tabelle, umgeleitet .

Option Explicit

Const ppPresName As String ="\Pfad\PowerPointPres.ppt"
'Normalweise der gleiche Pfad wie die Präsentation

Const LinkIni As String = "\Pfad\ppLink.ini"


Sub PP_Presentation_Start_and_Update_ObjectLinks()
'(C) Ramses
'Eine Powerpoint Präsentation enthält verschiedene verknüpfte Objecte auf eine EXCEL Tabelle
'Der Namen dieser Tabelle ändert sich jedoch immer wieder
'Um die manuellen Anpassungen zu umgehen werden diese automatisch upgedatet
'
'Dazu wird eine INI Datei angelegt in welcher die alte Verknüpfungsdatei gespeichert wird
'Existiert noch keine, wird eine INI Datei angelegt mit dem Bezug auf die AKTUELLE ARBEITSMAPPE
'Die Objecte in der Präsentation MÜSSEN beim erstmaligen Start also auf
'die aktuell geöffnete Mappe mit diesem Makro verweisen
'
'Beim starten wird dann gefragt ob auf eine neue Mappe Bezug genommen werden soll,
'der Benutzer wählt eine neue Datei aus ( Diese Datei MUSS Identisch sein mit der Originaldatei )
'd.h. die ursprünglich erstellte Datei darf nur unter einem anderen Namen gespeichert werden !!!
'Die Objectnamen dürfen NICHT geändert werden !!!
'
'Die Master-Tabelle kann kaskadieren nach dem Vater - Sohn Prinzip
'Aus der Sohn-Tabelle können weitere Objecte in die Präsentation kopiert werden
'wenn die Objecte mit den neuen Werten auf diese Sohn Tabelle verweisen
'werden diese auch aktualisiert.

'Bei einem Verweis auf die VATERTABELLE werden die Objecte in der Präsentation
'die in der Sohn-Tabelle vorhanden sind, nicht mehr dargestellt!!
'************************
'Integer Delaration
Dim As Integer, Qe As Integer
'Object Deklaration
Dim ppApp As Object, ppPres As Object, sh As Object
'String Deklaration
Dim ppFile As String, iniFile As String
Dim LinkFile As String, oldLinkfile As String, NewLinkfile As String
Dim tmpLink As String, onlyOldFileName As String, onlyNewFileName As String, cBSl As Integer
'Variablen füllen
NewLinkfile = ""
'Prüfen ob PP-Datei vorhanden
ppFile = ThisWorkbook.Path & ppPresName
If Dir(ppFile) = "" Then
      Beep
      Qe = MsgBox("Die Datei " & ppFile & " existiert nicht!", vbCritical + vbOKOnly, "Datei Fehler")
      Exit Sub
End If
'Zwischenspeichern des Namens für die Quelldatei
iniFile = ThisWorkbook.Path & LinkIni
'Prüfen ob INI Datei vorhanden
If Dir(iniFile) = "" Then
    Qe = MsgBox("Die Datei " & Chr$(13) & iniFile & Chr$(13) & "wurde noch nicht definiert," & Chr$(13) & _
        "Es wird eine neue " & Chr$(13) & LinkIni & Chr$(13) & "erstellt mit der Quelle zu " & Chr$(13) & _
        ThisWorkbook.FullName, vbInformation + vbOKCancel, "Source Fehler")
    If Qe = vbCancel Then
        Qe = MsgBox("Das Erstellen der Datei " & Chr$(13) & _
            LinkIni & Chr$(13) & _
            " wurde abgebrochen," & Chr$(13) & _
            "Das Makro zum Starten der Präsentation wird " & Chr(13) & _
            "gestoppt und die PP Links nicht upgedatet !", vbInformation + vbOKOnly, "Source Fehler")
            Exit Sub
    End If
    'Erstellen einer neuen Link.ini
    Open iniFile For Output As #1
        'Schreiben der aktuell geöffneten Datei als Verknüpfung
        Print #1, ThisWorkbook.FullName
    Close #1
End If
'Schliessen einer eventuell geöffneten INI-Datei
Close #1
'Der Speicherort der INI Datei wird in der Const LiniIni definiert
Open iniFile For Input As #1
Do While Not EOF(1)
    'Einlesen der SourceQuelle für die Präsentation
    Input #1, oldLinkfile
Loop
'Schliessen der Datei
Close #1

'Abfrage ob neue Verknüpfungdatei definiert werden soll
Qe = MsgBox("Die aktuelle Verknüpfungdatei von " & Chr$(13) & ppPresName & Chr$(13) & _
    "ist derzeit die Datei " & Chr$(13) & _
    oldLinkfile & "." & Chr$(13) & _
    "Soll die Verknüpfungsdatei geändert werden ?", vbQuestion + vbYesNo, "Source Definition")
If Qe = vbYes Then
    'Wenn ja
    NewLinkfile = Application.GetOpenFilename("XLS Dateien (*.xls),", True, "Neue Verknüpfungsdatei auswählen", "Übernehmen", False)
    'sicherheitsabfrage
    Qe = MsgBox("Soll die Datei " & Chr$(13) & NewLinkfile & Chr$(13) & "als neue Verknüpfung definiert werden?", _
        vbQuestion + vbOKCancel, "Source Definition")
    If Qe = vbNo Then
        'Verwendung der bisherigen Datei um Update der Präsentation
        Qe = MsgBox("Die Definition der Datei" & Chr$(13) & _
            NewLinkfile & Chr$(13) & _
            " wurde abgebrochen," & Chr$(13) & _
            "Es wird die alte Datei " & oldLinkfile & "verwendet !", vbInformation + vbOKOnly, "Source Definition")
    Else
        'Neue Linkdatei wird geschrieben und zum Update verwendet
        Open iniFile For Output As #1
        'Schreiben der aktuell geöffneten Datei als Verknüpfung
            Write #1, NewLinkfile
        Close #1
    End If
End If
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = msoTrue
Set ppPres = ppApp.Presentations.Open(ppFile)
'---------------------
'Verknüpfungen updaten
'Wenn die Verknüpfungdatei nicht geändert wurde
'werden nur die Werte aktualisiert
If NewLinkfile = "" Then
    For i = 1 To ppPres.Slides.Count
        For Each sh In ppPres.Slides(i).Shapes
            If sh.Type = msoLinkedOLEObject Then
                With sh.LinkFormat
                    .Update
                End With
            End If
        Next
    Next i
Else
    'Die Verknüpfungsdatei wurde geändert
    'Dazu muss der Filenamen extrahiert werden
    'den die directen Object Bezüge müssen ebenfalls angepasst werden
    'Variante für alle Excel Versionen
    cBSl = 0
    For i = Len(oldLinkfile) To Step -1
        If Mid(oldLinkfile, i, 1) = "\" Then
            onlyOldFileName = Right(oldLinkfile, Len(oldLinkfile) - i)
            Exit For
        End If
    Next i
    cBSl = 0
    For i = Len(NewLinkfile) To Step -1
        If Mid(NewLinkfile, i, 1) = "\" Then
            onlyNewFileName = Right(NewLinkfile, Len(NewLinkfile) - i)
            Exit For
        End If
    Next i
    For i = 1 To ppPres.Slides.Count
        For Each sh In ppPres.Slides(i).Shapes
            If sh.Type = msoLinkedOLEObject Then
                With sh.LinkFormat
                    'Externen Filebezug updaten
                    tmpLink = Replace(.SourceFullName, oldLinkfile, NewLinkfile, 1)
                    'Updaten der direkten Object Bezüge
                    tmpLink = Replace(tmpLink, onlyOldFileName, onlyNewFileName, 1)
                    .SourceFullName = tmpLink
                    .Update
                End With
            End If
        Next
    Next i
End If
'---------------------
ppPres.SlideShowSettings.Run
'ppApp.Quit