INSÉRER UN DOCUMENT PPT AUTOMATIQUEMENT DANS UN WORD

Private Sub OK_Click()
'
' Import_Ppt Macro
' Macro créée le 18/04/2007 par EDF-GDF
    
    On Error GoTo lblerror3
    
' test pour vérifier si il s'aigt bien d'un répertoire valide
    str_test = Me.Folder
    If Right(str_test, 1) <> "\" Then
        Me.Folder = str_test + "\"
    End If

' recup des formulaires
    
    nbrDiapo = Me.Nombre_diapo
    File_ppt = Me.Folder + Me.File
    
'   init
    
    StrExportdir = "Export"
    
    Strjpg = StrExportdir & ".jpg"
    
    Diapo = "Diapositive"
    
    SavedFolder = File_ppt + Strjpg + ".Jpg"
    
    SavedFolder_simple = File_ppt + StrExportdir + ".Jpg" + "\"
    
'   si pas de nombre de diapo erreur
    If nbrDiapo = "" Then GoTo lblerror2

' test: est ce un fichier ppt ?
    str_test = Me.File
    If Right(str_test, 4) <> ".ppt" And Right(str_test, 4) <> ".pps" Then
        
        msgbox "Le fichier doit être un fichier avec extenssion ppt ou pps"
        
        GoTo fin
    End If
    
' sauvegarde ppt en jpeg

    Dim ppt As New PowerPoint.Application
    
    ppt.Activate
'   ouverture
    ppt.Presentations.Open FileName:=File_ppt, ReadOnly:=msoFalse
'   sauvergarde en jpg
    ppt.ActivePresentation.SaveAs FileName:=SavedFolder, FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
'   fermeture
    ppt.ActivePresentation.Close
    ppt.Quit
    
' import jpeg
    
    On Error GoTo lblerror
   
    For i = 1 To nbrDiapo
        
        str_ = SavedFolder_simple & Diapo & i & ".JPG"
        ' importation du fichier jpg dans le word
        Selection.InlineShapes.AddOLEObject FileName:= _
            str_, LinkToFile:= _
            False, DisplayAsIcon:=False
    Next
    
    GoTo fin

lblerror:
    msgbox " L'importation a fonctionné, mais vous avez saisi un nombre de diapositives trop grand"
    
    GoTo fin

lblerror2:
    msgbox " Vous devez rentrez un nombre de diapositives (en chiffres ) "
    
    GoTo fin

lblerror3:
    msgbox " Erreur, Paramètres incorrects "
    
    GoTo fin

fin:


' sauvegarde du document
    ActiveDocument.Save
    
End Sub