Code gefunden aber - Laufzeifehler :-(
16.11.2010 14:57:42
Mapsi
mittlerweilen hab ich durch langes "googeln" folgenden Code gefunden, der eigentlich genau das machen müsste, was ich mir wünsche:
Function SelectArea() As String
Dim Internrange As Range
Dim rngBereich
Dim Rletzte, Cletzte As Long
On Error GoTo Brutt
Set Sourcebok = ActiveWorkbook
Rletzte = Range("A65536").End(xlUp).Row
Cletzte = Range("IV1").End(xlToLeft).Column
Set rngBereich = Range(Cells(1, 1), Cells(Rletzte, Cletzte + 1))
SelectArea = rngBereich.Address
Exit Function
Brutt:
SelectArea = "A1"
End Function
Function sShortname(ByVal Orrginal As String) As String
Dim iii As Long
sShortname = ""
For iii = 1 To Len(Orrginal)
If Mid(Orrginal, iii, 1) " " Then _
sShortname = sShortname & Mid(Orrginal, iii, 1)
Next
End Function
Function fctVerzeichnisExists(oname) As Boolean
On Error GoTo Fehler
ChDir oname
fctVerzeichnisExists = True
Exit Function
Fehler:
fctVerzeichnisExists = False
End Function
Public Sub Alle_Bilder_ppt()
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim oname As String
Dim Hi As Long
Dim Wi As Long
Dim Suffiks As Long
Dim Tagdat, tach, mon, ja As String
Dim Tabellen As Integer
Dim appPP As Object, Slide As Object
For Tabellen = 1 To Worksheets.Count 'Schleife über Tabellenblätter
Set Sourcebok = ActiveWorkbook
Worksheets(Tabellen).Activate
MySuggest = sShortname(ActiveSheet.Name)
Sourcebok.Activate
MyAddress = SelectArea
If MyAddress "A1" Then
Tagdat = Format(Date, "yyyy-mm-dd")
oname = "C:\Temp\PPts\" & Tagdat
If Not fctVerzeichnisExists(oname) Then
MkDir oname
Else
End If
SaveName = oname & "\" & MySuggest _
& ".ppt"
Range(MyAddress).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set appPP = CreateObject("PowerPoint.Application")
With appPP
.Visible = True
.Presentations.Open Filename:="C:\Temp\Leere-Vorlage.ppt", ReadOnly:=msoFalse
.ActivePresentation.Slides.Add 1, ppLayoutBlank
Set Slide = .ActivePresentation.Slides(1)
Slide.Shapes.Paste
With Slide.Shapes(1)
.Left = 30
.Top = 130
End With
End With
If SaveName = False Then
GoTo Avbryt
End If
With appPP
.Visible = msoTrue
.ActivePresentation.SaveAs (SaveName)
.ActivePresentation.Close
.Quit
End With
Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
Next Tabellen 'nächstes Worksheet
End Sub
Mein Problem ist nun aber, dass das Makro mir zwar eine PPT öffnet und dann aber bei der folgenden Zeile stehen bleibt:
.ActivePresentation.Slides.Add 1, ppLayoutBlank
Fehlermeldung: Laufzeifehler
Slides.Add:Invalid enumeration value
Was mach ich falsch oder was muss ich im obigen Code noch ändern ?
HERZLICHEN DANK FÜR DIE HILFE !