Extraction des icônes des menu d'office

Télécharger le projet
Commenter

Description

Chose demander plusieurs fois sur le forum.
J'ai donc décider de faire un petit code simple qui permet cela.
Mais, ce code ne marche que pour office Xp, 2002, 2003, 2007.

Pour office 2000, j'ai fait le code en vb6 car c'était plus simple à faire et plus rapide.
Donc, le projet est dans le zip (il faudra ajouter les références "Microsoft Excel Object Library" et "Microsoft Office Object Library" pour que ca marche.

Source / Exemple : 


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

Conclusion :


Avec ca on à 15934 icônes pour office 2007.
Pour l'amélioration, faudra filtrer les images ; la moitié des images extraites sont vides !!! (les menus sans icônes)
Pour le projet vb6, il détecte les images vides et les sauvegarde pas. Reste a le faire pour le projet vba.
Testé sous office 2000, 2003 et 2007.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (Charles Racaud)