114 Aufrufe
Gefragt in Windows 10 von
Hallo Zusammen,

ich würde gerne ein Makro erstellen um Bilder (.png) aus dem Explorer auf jeweils eine Folie in einer ppt. Präsentation einzufügen. Zuvor werden bereits aus eine Excel-Tabelle mehrere Artikelinformationen auf jeweils einer Folie eingefügt und jetzt soll noch ein Produktbild folgen. Kann mir jemand helfen?

4 Antworten

0 Punkte
Beantwortet von

Hallo Eva,

das Makro läuft auch unter Office 365.

meine Kommentare sind teils deutsch, teils Englisch.

leider ist das makro zu lang zum Einfügen, Anhängen geht wohl nicht. Ich könnte es per mail schicken...

Sub Insert_Graphics_Xcmwide()

' Makro für Powerpoint 2003ff

' Öffnet Dateiauswahlfenster für Grafiken in "Eigene Dateien" (mit FileDialog)

' Mehrfachauswahl ist möglich (2012-11-23: Reihenfolge geändert 1...n,0 statt 0....n)

' Jede ausgewählte Grafik wird in der linken oberen Ecke der Folie eingefügt,

' auf beliebige Breite skaliert und mit einem Rahmen versehen

' Titel: Filename

' Alternative Text: FullFilename und Datum, Uhrzeit

0 Punkte
Beantwortet von
Hallo Busmaster,

vielen Dank für deine Antwort. Leider bin ich kein Profi und das sagt mir jetzt alles nicht so wirklich viel. Das Makro wäre wirklich hilfreich. Kann man das hier nicht teilen?
0 Punkte
Beantwortet von
2. Versuch, ich habe keine Zeit die englischen Kommantare zu ändern..

Sub Insert_Graphics_Xcmwide()
' Makro für Powerpoint 2003ff
' Öffnet Dateiauswahlfenster für Grafiken in "Eigene Dateien" (mit FileDialog)
' Mehrfachauswahl ist möglich (2012-11-23: Reihenfolge geändert 1...n,0 statt 0....n)
' Jede ausgewählte Grafik wird in der linken oberen Ecke der Folie eingefügt,
' auf beliebige Breite skaliert und mit einem Rahmen versehen
' Titel: Filename
' Alternative Text: FullFilename und Datum, Uhrzeit

On Error GoTo ErrorHandler
    Dim fd As FileDialog                                        'Declare a variable as a FileDialog object.
    Set fd = Application.FileDialog(msoFileDialogOpen)          'Create a FileDialog object as a File Picker dialog box.
   
    Dim vrtSelectedItem As Variant                              'Declare a variable to contain the path of each selected item.
    Dim vntDatei As Variant
    
    Dim ImageW, ImageH, ImageR, Voreinstellung, WidthX As Variant
    Voreinstellung = "7"                                        ' Voreinstellung festlegen.
    Dim CmPoints As Double                                      '1cm = 28.346 Punkt
    CmPoints = 28.346
    
    Dim IB_Mldg1, IB_Mldg2, IB_Titel, FilesFilter1, FilesFilter2, FilesTitel As String
    Dim MB1_Titel, MB1_Text1, MB1_Text2, ErrMsg  As String
    Dim MB2_Titel, MB2_Text1, MB2_Text2, MB2_Text3 As String
    Dim nImages As Long
    Dim ImageAltText As String, ImageTitle As String
    Dim nPos As Integer
    ImageTitle = "Import"
        
        IB_Mldg1 = "Breite der Grafik"            ' Aufforderung festlegen.
        IB_Mldg2 = " (in cm):"                        ' Aufforderung festlegen.
        IB_Titel = "Grafik skalieren"               ' Titel festlegen.
        
        FilesFilter1 = "Grafik-Dateien"
        FilesFilter2 = "*.bmp; *.gif; *.jpg; *.tif; *.wmf"
        FilesTitel = "Grafik skaliert einfügen"
        
        MB1_Titel = "Hinweis"
        MB1_Text1 = "Keine Datei ausgewählt"
        
        MB2_Titel = "Problem"
        MB2_Text1 = "Angegebene Bildgröße:"
        MB2_Text2 = " mal "
        MB2_Text3 = " !!"
    
    With fd                                                     'Use a With...End With block to reference the FileDialog object.
        .AllowMultiSelect = True                                ' Mehrfachauswahl
        .Filters.Add FilesFilter1, FilesFilter2, 1   'Grafikfilter setzten
        .FilterIndex = 1
        .Title = FilesTitel
        .InitialView = msoFileDialogViewPreview
        .ButtonName = "Import"                                  'Button Beschriftung
        .InitialFileName = GetSpecialFolder(sfidPERSONAL)       'Standard Pfad: Eigene Dateien
        
        If .Show = -1 Then            
            'Step through the FileDialogSelectedItems collection.
            nImages = 0 ' Image counter
            For Each vrtSelectedItem In .SelectedItems          'vrtSelectedItem contains the path of each selected item.

                    WidthX = 0
                    If nImages > 0 Then 'skip index 0
                        Do      ' Bildbreite abfragen
                            WidthX = InputBox(IB_Mldg1 & vntDatei & IB_Mldg2, IB_Titel, Voreinstellung)
                            If Val(WidthX) > 0 Then Exit Do
                        Loop
                        
                        'Debug.Print "vrtSelectedItem", vrtSelectedItem
    
                        ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=vrtSelectedItem, _
                        LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0#, Top:=0#).Select
                        ImageW = ActiveWindow.Selection.ShapeRange.Width
                        ImageH = ActiveWindow.Selection.ShapeRange.Height
                        
                        ImageAltText = "Source file: " & vrtSelectedItem & " Imported: " & Now()
                        ImageTitle = vrtSelectedItem
                        nPos = InStrRev(ImageTitle, "\")
                        ImageTitle = Mid(ImageTitle, nPos + 1)
                        
                        If (ImageH > 0) And (ImageW > 0) Then
                            With ActiveWindow.Selection.ShapeRange
                                ImageR = ImageH / ImageW
                                .Width = WidthX * CmPoints
                                .Height = .Width * ImageR
                                .Left = 0#
                                .Top = 0#
                                .Fill.Visible = msoFalse
                                .Line.Visible = msoTrue
                                .Title = ImageTitle
                                .AlternativeText = ImageAltText
                            End With
                        Else
                            MsgBox MB2_Text1 & Str(ImageW) & MB2_Text2 & Str(ImageH) & MB2_Text3, 16, MB2_Titel & vrtSelectedItem
                        End If
                    End If
                    nImages = nImages + 1  ' inc Image counter
             Next vrtSelectedItem

             ' 2nd Run
            nImages = 0 ' Image counter
            For Each vrtSelectedItem In .SelectedItems      'vrtSelectedItem contains the path of each selected item.
                
                    WidthX = 0
                    If nImages = 0 Then ' only index 0
                        Do      ' Bildbreite abfragen
                            WidthX = InputBox(IB_Mldg1 & vntDatei & IB_Mldg2, IB_Titel, Voreinstellung)
                            If Val(WidthX) > 0 Then Exit Do
                        Loop
                        Debug.Print "vrtSelectedItem", vrtSelectedItem
    
                        ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=vrtSelectedItem, _
                        LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0#, Top:=0#).Select
                        ImageW = ActiveWindow.Selection.ShapeRange.Width
                        ImageH = ActiveWindow.Selection.ShapeRange.Height
                        
                        ImageAltText = "Source file: " & vrtSelectedItem & " Imported: " & Now()
                        ImageTitle = vrtSelectedItem
                        nPos = InStrRev(ImageTitle, "\")
                        ImageTitle = Mid(ImageTitle, nPos + 1)
                        
                        If (ImageH > 0) And (ImageW > 0) Then
                            With ActiveWindow.Selection.ShapeRange
                                ImageR = ImageH / ImageW
                                .Width = WidthX * CmPoints
                                .Height = .Width * ImageR
                                .Left = 0#
                                .Top = 0#
                                .Fill.Visible = msoFalse
                                .Line.Visible = msoTrue
                                .Title = ImageTitle
                                .AlternativeText = ImageAltText
                            End With
                            
                            
                        Else
                            MsgBox MB2_Text1 & Str(ImageW) & MB2_Text2 & Str(ImageH) & MB2_Text3, 16, MB2_Titel & vrtSelectedItem
                        End If
                    End If
                    nImages = nImages + 1  ' inc Image counter
                     
             Next vrtSelectedItem
        Else
            MsgBox MB1_Text1, 48, MB1_Titel
        End If
    End With
    'Set the object variable to Nothing.
    Set fd = Nothing
    Exit Sub
ErrorHandler:
   ' Create Error message and raise dialog box with error message.
   ErrMsg = "Error " & Err.Number & ": " & Err.Source & vbNewLine _
     & Err.Description
   MsgBox ErrMsg, vbCritical, "Error Message"
    
End Sub
0 Punkte
Beantwortet von
Guten Morgen,

die Zeile

FilesFilter2 = "*.bmp; *.gif; *.jpg; *.tif; *.wmf"

sollte geändert werden in

FilesFilter2 = "*.png; *.bmp; *.gif; *.jpg; *.tif; *.wmf" ' zeigt viele Bildformate an (auch png)

oder

FilesFilter2 = "*.png" ' zeigt nur PNG an

Viel Erfolg

Busmaster
...