Hallo Leute, ich arbeite seit neustem mit Makros und stehe jetzt vor einem Problem, welches mir den letzten Nerv raubt. Es geht dabei um PowerPoint und Excel.
Folgender Ablauf soll durch ein Makro in Excel ersetzt werden:
In der Spalte A1 steht eine Nummer, unter diesem Namen soll der Inhalt C1:E20 als Bild (Format momentan GIF, prinzipiell egal) abgespeichert werden, und zwar auf dem Pfad C:\
Momentan schaut mein Code so aus:
Sub Range_To_Image()
Dim objPict As Object, objChrt As Chart
Dim rngImage As Range, strFile As String
On Error GoTo ErrExit
With Sheets("Tabelle1") 'Tabellenname - Anpassen!
Set rngImage = .Range("C3:F18")
rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
Set objPict = .Shapes(.Shapes.Count)
strFile = "C:\1.gif" 'Pfad und Dateiname für das Bild
objPict.Copy
Set objChrt = .ChartObjects.Add(1, 1, objPict.Width + 8, objPict.Height + 8).Chart
objChrt.Paste
objChrt.Export strFile
objChrt.Parent.Delete
objPict.Delete
End With
ErrExit:
Set objPict = Nothing
Set objChrt = Nothing
Set rngImage = Nothing
End Sub
Nun soll in PowerPoint ein Makro möglich sein, welches mich nach dem Start in einen Dateiöffnungsdialog führt, aus dem ich dann eines der vorher erstellten Bilder auswählen kann, dieses soll dann in PowerPoint eingeladen werden auf die aktuell angewählte Folie und dort in die bestimmte Größe gebracht, horizontal zentrisch und mit dem definierten Abstand nach oben.
Momentan habe ich dazu 3 Makros die allerdings nicht ganz so funktionieren wie ich das gerne hätte.
Die Größe und Position ändere ich nach selektion des Bildes sobald es auf der Folie ist mit:
Sub SizeAndPosition()
' Usage: Select two shapes. The size and position of
' the first shape selected will be copied to the second.
Dim w As Double
Dim h As Double
Dim l As Double
Dim t As Double
With ActiveWindow.Selection.ShapeRange(1)
.Width = 714.0472440945
.Height = 466.2992125984
End With
With ActivePresentation.PageSetup
x = .SlideWidth / 2
End With
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.Type = msoPicture Then
oshp.Left = x - (oshp.Width / 2)
oshp.Top = 0.25
End If
Next
Next
End Sub
Der Dateiöffnungsdialog ist leider auch fehlerhaft, denn nach Import wird die Datei nicht auf die Folie gebracht geschweige denn angewählt:
Sub Open()
Dim dlgOpen As FileDialog
Dim strDatei As String
Set dlgOpen = Application.FileDialog(msoFileDialogOpen)
With dlgOpen
'nur eine auswählbar True = mehrere Dateien auswählbar
.AllowMultiSelect = False
.Show
On Error Resume Next
strDatei = .SelectedItems(1)
If Err <> 0 Then
MsgBox "Es wurde keine Datei ausgewählt", _
vbInformation + vbOKOnly, "Titel"
Else
MsgBox "Ausgewählte Datei: " & strDatei, _
vbInformation + vbOKOnly, "Titel"
End If
On Error GoTo 0
End With
End Sub
Wenn mir da jemand eine Hilfestellung zu geben könnte wäre das richtig Spitze ! ?
|