Gemme PP fil inde fra Excel

Sub Dias()
'
' Range
'
    Application.Goto Reference:="Område i excel"
'
' KopierTilBillede
'
    Selection.CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture
    Application.Goto Reference:="Område i Excel"
    ActiveSheet.Paste
'
' Billedstørrelse
'
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = 363.75
    Selection.ShapeRange.Width = 682.5
    Selection.ShapeRange.Rotation = 0#
    Selection.Copy
'
' OpretDias
'
Dim PPApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim strFILNAVN As String
Dim strHDMAPPE As String


    strHDMAPPE = "C:\"
   
    Set PPApp = CreateObject("Powerpoint.Application")
    Set PPTPres = PPApp.Presentations.Add
    PPApp.Visible = True
    PPApp.ActiveWindow.ViewType = ppViewSlide
   
    With PPTPres.Slides
    Set PPTSlide = .Add(.Count + 1, ppLayoutText)
    End With
    Set PPTSlide = PPTPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture

    PPApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
    PPApp.ActiveWindow.View.Paste
    PPApp.ActiveWindow.Selection.Unselect
    PPApp.Activate
   
    gem = MsgBox("Skal dias gemmes", vbYesNo, "Skal dias gemmes")
    If gem = 6 Then
    FILNAVN = InputBox("Gem Dias som:", "Gem Dias")
    PPApp.ActivePresentation.SaveAs Filename:=strHDMAPPE & FILNAVN & " " & Date
    Else
    End If
   
   
   
   
    Set PPTSlide = Nothing
    Set PPTPres = Nothing
    Set PPApp = Nothing
    Selection.Delete 'Område i Excel - lavet om til billede, fernes'
   
   
End Sub

Det ser ud til at virke - nej, det virker, men dialogboksene åbner op i excel, hvilket ikke er så godt,da man står i pp (har muligvis forklaret mig lidt for kryptisk). Hvad nu hvis man gemmer fil med samme navn, samme dag - kunne man evt sætte klokkeslet på, så bliver de i hvert tilfælde unikke - øh hvordan.  strHDMAPPE & FILNAVN & " " & Date & " " & ??????

Hvis du skifter DATE ud med NOW får du også klokkeslet på.

Jeg ved ikke helt hvordan man kommer ud over problemet med at Popup kommer i excel. Vil prøve at tænke over det.

Jeg har fundet ud af og sætte en skabelon ind, samt løst problemet med dialogboksene. Det er fint nok, at stå inde i Excel og besvare boksene, da diasbillede er taget der. Så snart man har gemt filen, går man tilbage til PowerPoint. Når man lukker der, går man så tilbage til excel.

Tilbage er der så... Når jeg sætter "Now" ind får jeg en fejl:Presentation (Unknown member): Der opstod en fejl, mens PowerPoint gemte filen.

Sub Dias2()
'
' Range
'
    Application.Goto Reference:="Område1 i Excel"
'
' KopierTilBillede
'
    Selection.CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture
    Application.Goto Reference:="Område2 i Excel - paste billede"
    ActiveSheet.Paste
'
' Billedstørrelse
'
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = 363.75
    Selection.ShapeRange.Width = 682.5
    Selection.ShapeRange.Rotation = 0#
    Selection.Copy
'
' OpretDias
'
Dim PPApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim strFILNAVN As String
Dim strHDMAPPE As String


    strHDMAPPE = "K:\Kundebesøg på genbrugsstationer (Datalog)\Excel dataudtræk\Testfiler\"
   
    Set PPApp = CreateObject("Powerpoint.Application")
    Set PPTPres = PPApp.Presentations.Add
    PPApp.Visible = True
    PPApp.ActiveWindow.ViewType = ppViewSlide
   
    With PPTPres.Slides
    Set PPTSlide = .Add(.Count + 1, ppLayoutText)
    End With
    PPApp.ActivePresentation.ApplyTemplate Filename:="c:\Min fil PowerPoint.ppt"
    Set PPTSlide = PPTPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture

    PPApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
    PPApp.ActiveWindow.View.Paste
    PPApp.ActiveWindow.Selection.Unselect
    PPApp.Activate
    PPApp.WindowState = 2
       
    gem = MsgBox("Skal dias gemmes?.", vbYesNo, "Skal dias gemmes?")
    If gem = 6 Then
    FILNAVN = InputBox("Gem Dias som:", "Gem Dias")
    PPApp.ActivePresentation.SaveAs Filename:=strHDMAPPE & FILNAVN & " " & Date
    Else
    End If
   
    PPApp.Activate
    Set PPTSlide = Nothing
    Set PPTPres = Nothing
    Set PPApp = Nothing
    Selection.Delete 'Område i Excel - pastebillede, fjernes'
    Application.Goto Reference:="Poul"

End Sub

Hej Jeg har leget med min tidligere kode. Fejlen i "Now" opstod naturligvis, da man ikke kan gemme filer med ":" i filnavnet.

Jeg har bare lavet en dato string med andet format.

Sub Dias()
'
' Range
'
    Application.Goto Reference:=Range("a1")
' KopierTilBillede
'
    Selection.CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture
    Application.Goto Reference:=Range("a1")
    ActiveSheet.Paste
'
' Billedstørrelse
'
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = 363.75
    Selection.ShapeRange.Width = 682.5
    Selection.ShapeRange.Rotation = 0#
    Selection.Copy
'
' OpretDias
'
Dim PPApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim strFILNAVN As String
Dim strHDMAPPE As String
Dim strdato As String


    strHDMAPPE = "C:\"
    strdato = Format(Now(), "dd-mm-yy - hh-mm-ss")
   
    Set PPApp = CreateObject("Powerpoint.Application")
    Set PPTPres = PPApp.Presentations.Add
    PPApp.Visible = True
    PPApp.ActiveWindow.ViewType = ppViewSlide
   
    With PPTPres.Slides
    Set PPTSlide = .Add(.Count + 1, ppLayoutText)
    End With
    Set PPTSlide = PPTPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture

    PPApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
    PPApp.ActiveWindow.View.Paste
    PPApp.ActiveWindow.Selection.Unselect
    PPApp.Activate
   
    gem = MsgBox("Skal dias gemmes", vbYesNo, "Skal dias gemmes")
    If gem = 6 Then
    strFILNAVN = InputBox("Gem Dias som:", "Gem Dias")
    PPApp.ActivePresentation.SaveAs Filename:=strHDMAPPE & strFILNAVN & " " & strdato
    Else
    End If
   
   
   
   
    Set PPTSlide = Nothing
    Set PPTPres = Nothing
    Set PPApp = Nothing
    Selection.Delete 'Område i Excel - lavet om til billede, fernes'
   
   
End Sub

Jamen, så kører det. Tusind tak for hjælpen.Ligger du et svar?

Et svar:-)