EXTRACTION DES ICÔNES DES MENU D'OFFICE

Option Explicit

Public Sub GetOfficeButton()

  ' Affiche une boîte de dialogue pour choisir le dossier d'extraction
  Dim Dlg As Office.FileDialog
  Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
  Dlg.AllowMultiSelect = False
  Dlg.Show
  Dlg.InitialFileName = Application.ThisWorkbook.Path & "\"
  If Dlg.SelectedItems.Count > 0 Then
  
    Const FileExt As String = ".bmp"
    Const nbFileDigit As Integer = 5
  
    Dim ExtractDirectory As String: ExtractDirectory = Dlg.SelectedItems(1)
    If Right$(ExtractDirectory, 1) <> "\" Then ExtractDirectory = ExtractDirectory & "\"

    ' Bouton temporaire
    Dim TblBtn As Office.CommandBarButton
    Set TblBtn = Application.CommandBars(1).Controls.Add(Office.msoControlButton)

    ' Extraction
    On Error Resume Next
    Dim nBtn As Integer
    Do ' Comme on ne connait pas le nombre de boutons
      nBtn = nBtn + 1 ' Incrémente le nombre de boutons trouvés
      TblBtn.FaceId = nBtn ' Attribut l'image du bouton
      If Err.Number = -2147467259 Then Exit Do ' Si le bouton n'a pas été trouvé (on est arrivé à la fin), on quitte la boucle
      Dim BtnId As String: BtnId = FormatInt(nBtn, nbFileDigit) ' Formatage du nom de l'image
      SavePicture TblBtn.Picture, ExtractDirectory & BtnId & FileExt ' Enregistre l'image
    Loop
    Err.Clear
    On Error GoTo 0
      
    MsgBox "Terminer" & vbNewLine & nBtn & " images extraites.", vbInformation, "GetOfficeButton"
    
    TblBtn.Delete ' Supprime le bouton temporaire
  End If
End Sub

Private Function FormatInt(ByVal n As Integer, ByVal Lenght As String) As String
  Dim sn As String: sn = CStr(n)
  If Len(sn) < Lenght Then
    FormatInt = String(Lenght - Len(sn), "0") & sn
    Exit Function
  End If
  FormatInt = n
End Function

Télécharger le zip

14 juillet 2006 20:52:02 :

Ajoute du projet vb6 pour la compabilité avec office 2000.

01 novembre 2006 17:43:45 :

Ajout d'une progression