Attribute VB_Name = "PP_Makros"
Option Explicit

Sub XLBlattEinfügen()
    'Fügt ein Arbeitsmappenblatt (Diagramm oder Tabelle) aus einer
    'per Dialog wählbaren XLS-Datei als neue Folie ein.
    '© 2000, Ralf Nebelo

    Dim objXL As Object
    Dim vntDatei As Variant
    Dim objBlatt As Object
    Dim blnEinfügen As Boolean
    Dim objNeueFolie As Slide
    Dim objNeuesShape As Shape

    Set objXL = CreateObject("Excel.Application")
    If objXL Is Nothing Then
        MsgBox "Excel kann nicht gestartet werden."
        Exit Sub
    End If
    
    vntDatei = objXL.GetOpenFilename(FileFilter:="Excel-Dateien (*.xls), *.xls", Title:="Arbeitsmappenblatt einfügen")
    If vntDatei <> False Then
        blnEinfügen = False
        objXL.Workbooks.Open vntDatei
        If objXL.ActiveWorkbook.Sheets.Count > 1 Then
            With frmListenfeld
                .Caption = "Arbeitsmappenblatt einfügen"
                .lstListe.Clear
                For Each objBlatt In objXL.ActiveWorkbook.Sheets
                    .lstListe.AddItem objBlatt.Name
                Next
                
                .Show vbModal
                If .lstListe.Value > "" Then
                    objXL.ActiveWorkbook.Sheets(.lstListe.Value).Select
                    objXL.ActiveWorkbook.Save
                    blnEinfügen = True
                End If
            End With
            Unload frmListenfeld
        Else
            blnEinfügen = True
        End If
        
        objXL.ActiveWorkbook.Close
        objXL.Quit
    End If

    Set objXL = Nothing
    
    If blnEinfügen = True Then
        Set objNeueFolie = ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)
        Set objNeuesShape = objNeueFolie.Shapes.AddOLEObject(Left:=0, Top:=0, Width:=70, Height:=70, FileName:=vntDatei, Link:=msoFalse)
        With objNeuesShape
            .ScaleHeight 1, True
            .ScaleWidth 1, True
        End With
        ActiveWindow.View.GotoSlide Index:=objNeueFolie.SlideIndex
    End If
End Sub
