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