Réaliser un complément PowerPoint pour générer un diaporama à partir d'un dossier

Const JPG As String = "jpg"
Const BMP As String = "bmp"
Const WMF As String = "wmf"
Const EMF As String = "emf"

HKEY_CURRENT_USER\Software\VB and VBA Program Settings\

C:\Documents and Settings\Argyronet\Application Data\Microsoft\Macros complémentaires

Option Explicit
 
Public Const APP_NAME As String = "DiaporamaCreator"
Public Const KEY_SETTINGS As String = "Settings"
Public Const VALUE_LASTPATHUSED As String = "LastPathUsed"
Public Const VALUE_DONOTSHOWATSTARTUP As String = "DoNotShowAtStartup"
Public Const MENU_NAME As String = "Insert"
Public Const MENU_NAME_FR As String = "Insertion"
Public Const ICON_CAPTION As String = "Créer un diaporama..."
 
Private Const ACTION_TO_DO As String = "InsertAutoFitPicturesIntoSlides"
Private Const TOOL_TIP_TEXT As String = "Génération d´un diaporama"
Private Const ICON_DESCRIPTION As String = "insère des photos ajustées pour la génération d´un diaporama"
Private Const ICON_TAG As String = "TAG_InsertAutoFitPictureIntoSlides"
 
Private Const THIS_PRESENTATION_PPT As String = "DiaporamaCreator.ppt"
Private Const THIS_PRESENTATION_PPA As String = "DiaporamaCreator.ppa"
 
Sub Auto_Open()
Dim oBar As CommandBar
Dim oControl As CommandBarControl
Dim oCBMenu As CommandBars
Dim blnFound As Boolean
Dim blnValue As Boolean
Dim I As Integer
 
 
    On Error Resume Next
    Set oCBMenu = Application.CommandBars
    For Each oControl In oCBMenu(MENU_NAME).Controls
        If oControl.Tag = ICON_TAG Then
            blnFound = True
            Exit For
        End If
    Next oControl
 
    If blnFound = False Then
        On Error Resume Next
        Set oControl = CommandBars(MENU_NAME).Controls.Add(msoControlButton)
            With oControl
                .BeginGroup = msoTrue
                .FaceId = 1362
                .OnAction = ACTION_TO_DO
                .TooltipText = TOOL_TIP_TEXT
                .Caption = ICON_CAPTION
                .DescriptionText = ICON_DESCRIPTION
                .Visible = msoTrue
                .Style = msoButtonCaption
                .Tag = ICON_TAG
            End With
    End If
 
    Set oControl = Nothing
 
    blnValue = CBool(GetSetting(APP_NAME, KEY_SETTINGS, VALUE_DONOTSHOWATSTARTUP))
    If blnValue = False Then frmWelcome.Show
    On Error GoTo 0
    DoEvents
    CloseAddinsPopup
End Sub
 
Sub Auto_Close()
Dim oBar As CommandBar
Dim oControl As CommandBarControl
Dim oCBMenu As CommandBars
 
    On Error Resume Next
    Set oCBMenu = Application.CommandBars
    For Each oControl In oCBMenu(MENU_NAME).Controls
        If oControl.Tag = ICON_TAG Then
          oControl.Delete
        End If
    Next oControl
    Set oCBMenu = Nothing
End Sub
 
Sub InsertAutoFitPicturesIntoSlides()
Dim straFilesName() As String
Dim strFilesName As String
Dim strPictureName As String
Dim strPath As String
Dim strDelay As String
Dim strFileName As String
Dim strLastFolderUsed As String
Dim I As Integer
 
    If Presentations.Count <> 0 Then
        If ActivePresentation.Name <> THIS_PRESENTATION_PPT And ActivePresentation.Name <> THIS_PRESENTATION_PPA Then
            If MsgBox("Voulez-vous utiliser la présentation active (" & ActivePresentation.Name & ") pour insérer les photos ?", _
            36, "Utiliser la présentation") = 6 Then
                If ActiveWindow.ViewType <> ppViewSlideSorter Then
                   ActiveWindow.ViewType = ppViewSlideSorter
                End If
            Else
                CreateNewPresentation
            End If
        Else
            CreateNewPresentation
        End If
    Else
        CreateNewPresentation
    End If
 
    ActiveWindow.ViewType = ppViewSlide
    strDelay = InputBox("Combien de secondes entre chaque photo ?", "Durée du cycle", "5")
    If Len(strDelay) Then
      If IsNumeric(strDelay) = msoFalse Then
        Exit Sub
      End If
    Else
      Exit Sub
    End If
 
    strLastFolderUsed = GetSetting(APP_NAME, KEY_SETTINGS, VALUE_LASTPATHUSED)
    If Len(strLastFolderUsed) = 0 Then
        strLastFolderUsed = Left(ActivePresentation.Path, 3)
    End If
    strPath = GetPicturesFolder(strLastFolderUsed)
    strLastFolderUsed = strPath
    strFilesName = GetFileString(strPath)
 
    If Len(strFilesName) = 0 Then
        MsgBox "Exécution annulée par l´utilisateur !", 48, "Fin"
        Exit Sub
    Else
      straFilesName = Split(strFilesName, SEPARATOR)
    End If
 
    For I = LBound(straFilesName) To UBound(straFilesName)
      strPictureName = strPath & Trim(straFilesName(I))
      AutoFitCurrentPicture strPictureName
      If I < UBound(straFilesName) Then
        ActiveWindow.View.GotoSlide ActivePresentation.Slides.Add(ActivePresentation.Slides.Count, ppLayoutBlank).SlideIndex
      End If
    Next
 
    If MsgBox("Le diaporama est maintenant créé..." & vbCrLf & vbCrLf & "Voulez-vous l´enregistrer ?" & vbCrLf & _ 
    vbCrLf & "Note : Le dossier cible sera" & vbCrLf & strPath, 36, "Enregistrer la présentation") = 6 Then
      strFileName = "Diaporama No " & Format(Now, "dmyyyy hhmmss")
      ActivePresentation.SaveAs strPath & strFileName, ppSaveAsShow, msoFalse
    End If
 
    ShowDiaporama CInt(strDelay)
 
    With ActivePresentation.SlideShowSettings
      .Run
    End With
End Sub
 
Private Sub SetSlideBackground()
    If ActivePresentation.HasTitleMaster Then
        With ActivePresentation.TitleMaster.Background
            .Fill.Visible = msoTrue
            .Fill.ForeColor.SchemeColor = ppTitle
            .Fill.Transparency = 0#
            .Fill.OneColorGradient msoGradientFromTitle, 2, 0.89
        End With
    End If
    With ActivePresentation.SlideMaster.Background
        .Fill.Visible = msoTrue
        .Fill.ForeColor.SchemeColor = ppTitle
        .Fill.Transparency = 0#
        .Fill.OneColorGradient msoGradientFromTitle, 2, 0.89
    End With
    With ActivePresentation.Slides.Range
        .FollowMasterBackground = msoTrue
        .DisplayMasterShapes = msoTrue
    End With
End Sub
 
Private Sub AutoFitCurrentPicture(ByVal FileName As String)
Dim oShape As ShapeRange
Dim sngPictureWidth As Single
Dim sngPictureHeight As Single
Dim sngSlideWidth As Single
Dim sngSlideHeight As Single
Dim sngScaleValue As Single
 
  ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName, msoFalse, msoTrue, 0, 0).Select
  Set oShape = ActiveWindow.Selection.ShapeRange
 
  sngPictureWidth = oShape.Width
  sngPictureHeight = oShape.Height
  sngSlideWidth = ActivePresentation.PageSetup.SlideWidth
  sngSlideHeight = ActivePresentation.PageSetup.SlideHeight
 
  If sngPictureWidth > sngPictureHeight Then
      sngScaleValue = sngSlideWidth / sngPictureWidth
  Else
      sngScaleValue = sngSlideHeight / sngPictureHeight
  End If
  sngScaleValue = sngScaleValue - 0.16
 
  oShape.ScaleHeight CSng(sngScaleValue), msoTrue
  oShape.ScaleWidth CSng(sngScaleValue), msoTrue
 
  With ActivePresentation.PageSetup
      oShape.Left = (.SlideWidth \ 2) - (oShape.Width \ 2)
      oShape.Top = (.SlideHeight \ 2) - (oShape.Height \ 2)
      oShape.Select
  End With
End Sub
 
Private Sub CreateNewPresentation()
    Presentations.Add msoTrue
    ActiveWindow.View.GotoSlide ActivePresentation.Slides.Add(1, ppLayoutBlank).SlideIndex
    SetSlideBackground
End Sub
 
Private Sub ShowDiaporama(ByVal Delay As Integer)
 
  ActiveWindow.ViewType = ppViewSlideSorter
  ActivePresentation.Slides.Range.Select
  With ActivePresentation.Slides.Range.SlideShowTransition
    .EntryEffect = ppEffectFade
    .Speed = ppTransitionSpeedSlow
    .AdvanceOnClick = msoTrue
    .AdvanceOnTime = msoTrue
    .AdvanceTime = Delay
    .SoundEffect.Type = ppSoundNone
  End With
  With ActivePresentation.SlideShowSettings
    .ShowType = ppShowTypeSpeaker
    .LoopUntilStopped = msoTrue
    .ShowWithNarration = msoTrue
    .ShowWithAnimation = msoTrue
    .RangeType = ppShowAll
    .AdvanceMode = ppSlideShowUseSlideTimings
    .PointerColor.SchemeColor = ppForeground
  End With
End Sub

Option Explicit
 
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXPLORER As Long = &H80000
 
Private Const BIF_STATUSTEXT  As Long = &H4&
Private Const BIF_RETURNONLYFSDIRS  As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN  As Long = 2
Private Const MAX_PATH  As Long = 260
 
Private Const WM_USER  As Long = &H400
Private Const BFFM_INITIALIZED  As Long = 1
Private Const BFFM_SELCHANGED  As Long = 2
Private Const BFFM_SETSTATUSTEXT  As Long = (WM_USER + 100)
Private Const BFFM_SETSELECTION  As Long = (WM_USER + 102)
 
Public Const SEPARATOR As String = "|"
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SendMessage Lib "user32" Alias _
  "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam _
  As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As _
  BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal _
  pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias _
  "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As _
  Long
 
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd _
  As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias _
  "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As _
  String) As Long
Private Declare Function PostMessage Lib "user32" Alias _
  "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam _
  As Long, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias _
  "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, _
  ByVal nMaxCount As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
  ByVal nCmdShow As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Const WM_CLOSE = &H10
Private Const ADDIN_POPUP_CLASSNAME As String = "#32770"
Private Const ADDIN_POPUP_TITLE As String = "Macros complémentaires"
 
Private Type BROWSEINFO
    hwndOwner      As Long
    pidlRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type
 
Private m_strDirectory As String
 
Public Sub CloseAddinsPopup()
Dim lngHWnd As Long
 
    lngHWnd = FindWindow(ADDIN_POPUP_CLASSNAME, ADDIN_POPUP_TITLE)
    Call SetForegroundWindow(lngHWnd)
    If lngHWnd Then
        PostMessage lngHWnd, WM_CLOSE, 0&, 0&
    End If
End Sub
 
Public Function GetPicturesFolder(ByVal StartPath As String) As String
Dim strFolder As String
    strFolder = BrowseForFolder(StartPath)
    If Len(strFolder) Then
        SaveSetting APP_NAME, KEY_SETTINGS, VALUE_LASTPATHUSED, strFolder
        strFolder = AddDirSep(strFolder)
    End If
    GetPicturesFolder = strFolder
End Function
 
Private Function StripNullChar(ByVal Buffer As String) As String
Dim intPosition As Integer
    intPosition = InStr(Buffer, vbNullChar)
    If intPosition > 0 Then
        StripNullChar = Left(Buffer, intPosition - 1)
    Else
        StripNullChar = Buffer
    End If
End Function
 
Private Function AddDirSep(strPathName As String)
    If Right(Trim(strPathName), Len("\")) <> "\" And _
       Right(Trim(strPathName), Len("\")) <> "\" Then
        strPathName = RTrim$(strPathName) & "\"
    End If
    AddDirSep = strPathName
End Function
 
Public Function GetFileString(ByVal Path As String) As String
Dim oFSO As Object ' As Scripting.FileSystemObject
Dim oFld As Object ' As Scripting.Folder
Dim oFile As Object ' As Scripting.File
Dim strFilesName As String
Dim strFilePath As String
Dim strType As String
Dim I As Integer
 
Const JPG As String = "jpg"
Const BMP As String = "bmp"
Const WMF As String = "wmf"
Const EMF As String = "emf"
 
    Set oFSO = CreateObject("Scripting.FileSystemObject")
'    Set oFSO = New FileSystemObject
    Set oFld = oFSO.GetFolder(AddDirSep(Path))
    For Each oFile In oFld.Files
        strType = Mid(oFile.Name, InStrRev(oFile.Name, ".") + 1)
        Select Case LCase(strType)
            Case JPG, BMP, WMF, EMF
                strFilesName = strFilesName & oFile.Name & SEPARATOR
            Case Else
        End Select
    Next
    If Len(strFilesName) Then
        GetFileString = Left(strFilesName, Len(strFilesName) - 1)
    End If
    Set oFld = Nothing
    Set oFile = Nothing
    Set oFSO = Nothing
End Function
 
Public Function BrowseForFolder(StartDir As String) As String
Dim lngReturn As Long
Dim strBuffer As String
Dim udtBrowseInfo As BROWSEINFO
 
  m_strDirectory = StartDir & vbNullChar
 
  With udtBrowseInfo
    .hwndOwner = 0
    .lpszTitle = lstrcat("Sélection d´un dossier contenant des photos...", " ")
    .ulFlags = BIF_RETURNONLYFSDIRS
    .lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
  End With
 
  lngReturn = SHBrowseForFolder(udtBrowseInfo)
  If (lngReturn) Then
    strBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lngReturn, strBuffer
    CoTaskMemFree lngReturn
    strBuffer = StripNullChar(strBuffer)
    BrowseForFolder = strBuffer
  Else
    BrowseForFolder = vbNullString
  End If
 
End Function
 
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMessage As Long, ByVal lpIDList As Long, _
ByVal pData As Long) As Long
Dim lngRet As Long
Dim strBuffer As String
 
  On Error Resume Next
  Select Case uMessage
    Case BFFM_INITIALIZED
        Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_strDirectory)
    Case BFFM_SELCHANGED
      strBuffer = Space(MAX_PATH)
      lngRet = SHGetPathFromIDList(lpIDList, strBuffer)
      If lngRet = 1 Then
        Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, strBuffer)
      End If
  End Select
  BrowseCallbackProc = 0
End Function
 
Private Function GetAddressOfFunction(P As Long) As Long
  GetAddressOfFunction = P
End Function

Option Explicit
 
Private Sub chkDontShow_Click()
    SavePreferences chkDontShow.Value
End Sub
 
Private Sub cmdOK_Click()
    SavePreferences chkDontShow.Value
    Unload Me
End Sub
 
Private Sub UserForm_Activate()
Dim strMessage As String
 
    strMessage = "Vous êtes prêt(e) à créer un diaporama à partir des photos que vous allez sélectionner..." & _
    vbCrLf & vbCrLf & "Dans le menu [" & MENU_NAME_FR & "], choisissez la rubrique [" & _
    ICON_CAPTION & "]."
    lblMessage.Caption = strMessage
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = (CloseMode = vbFormControlMenu)
End Sub
 
Private Sub SavePreferences(ByVal ShowAtStartup As Boolean)
    SaveSetting APP_NAME, KEY_SETTINGS, VALUE_DONOTSHOWATSTARTUP, ShowAtStartup
End Sub