EXTRACTION DES ICÔNES DES MENU D'OFFICE office, icone, image, boutons, barredoutils, Source N°38526

Information sur la source

Catégorie :VBA Classé sous : office, icone, image, boutons, barredoutils Niveau : Débutant Date de création : 11/07/2006 Date de mise à jour : 01/11/2006 17:43:45 Vu / téléchargé: 11 306 / 1 041

Auteur : Charles Racaud

Site perso

Ecrire un message privé

Ce membre participe au partage de revenus publicitaires

Note :

9,00 / 10

1
2
3
4
5
6
7
8
9
10

Commentaire sur cette source (12)

Ajouter un commentaire et/ou une note

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

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

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.

Fichier Zip

Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

GetOfficeButton.xls49 152 octets
PourOffice2000
- Form1.frm 6 461 octets
- Projet1.vbp 624 octets

Télécharger le zip

Historique

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

Sources du même auteur

Toutes les sources de Charles Racaud

Sources de la même categorie

Toutes les sources de la catégorie VBA

Sources en rapport avec celle ci

Commentaires

Commentaire de PCPT le 11/07/2006 22:57:08 administrateur CS

(ne fonctionne apparemment pas sous Excel 2000)
Commentaire de littlemaelstrom le 12/07/2006 08:59:12

Je confirme, cela ne fonctionne pas sous Office 2000 à cause du "Office.FileDialog" qui n'existe pas.

Dommage car c'était une très bonne idée. Peut-être qu'il existe une fonction équivalente à FileDialog dans le vba de excel 2000 qui pourrait faire l'affaire ?

Merci quand même pour ce code !
Commentaire de PCPT le 12/07/2006 09:15:41 administrateur CS

chemin remplaçable (voir chemin du dialogbox par défaut), c'est après que c'est gênant ...
Commentaire de Charles Racaud le 12/07/2006 11:56:18

Merci pour votre constatation, je corrige ca si je trouve un office 2000 dans les parages.
Oui, sinon, y'a la possibilité de remplacer le chemin par une constante, c'est pas un problème, reste juste à savoir si le reste marche.
Commentaire de PCPT le 12/07/2006 12:18:53 administrateur CS

(rappel : sous Excel 2000) à part les 2 constantes, tout virer avant le comm :
' Bouton temporaire

y mettre en dessous :
Dim ExtractDirectory As String
ExtractDirectory = Application.ThisWorkbook.Path & "\"

l'erreur (malgré le On Error) est sur :
SavePicture TblBtn.Picture, ExtractDirectory & BtnId & FileExt

est sélectionnée la propriété ".Picture" (Méthode introuvable)

sinon c'est la 2e fois que je lance VBA...
à défaut de pouvoir regarder tes sources en DotNet... quelle déception ^^
++
Commentaire de Charles Racaud le 12/07/2006 18:36:10

Bon, après quelques essais:
La boite de dialogue peut être remplacer par APIs
Par contre, pour la propriété Picture qui n'existe pas, elle peut être remplacer par la méthode CopyFace qui place l'image dans le presse-papier, mais pour la récupéré, c'est une autre histoire.
L'objet ClipBoard n'existe pas en VBA, et les APIs, galère galère, ca ne donne rien de bon.

Voilà, je continue toujours à chercher.

Hhaa, ce .net si différant du vb6 ...
Commentaire de Charles Racaud le 14/07/2006 20:54:04

Voila une maj:
Le projet vb6 permet d'extraire et de filtrer les images pour office 2000.

Merci à PCPT pour son aide.
Commentaire de Exploreur le 01/11/2006 15:16:36

salut,

c'est exactement ce que je chercher.
9/10
A+
Exploreur
Commentaire de Exploreur le 01/11/2006 16:11:17

Serait cool que tu mettes une progress abr pour avoir l'avancement de l'extration des icones...j'ai eu + de 10000 fichiers et je me demandais si le prog avait planter !Lol.
Serait bien aussi de pouvoir enregistrer les extractions dans un répertoire choisi par l'utilisateur au lieu de la faire dans le répertoire choisi pour faire commencer l'extraction.
A+
Exploreur
Commentaire de Charles Racaud le 01/11/2006 16:31:04

Ok, merci pour tes commentaires.
Je vais reprendre un peu tout ca.
Commentaire de Pym Corp le 29/11/2006 11:38:23

Tu pourrais faire une version .NET qui conserve les canaux alpha ?
Les images ressortent sur fond noir :(
Une sortie en .png ou .ico serait cool :)
Commentaire de Charles Racaud le 29/11/2006 21:47:04

Oui, je verrai ca. C'est vrai qu'on pourrait faire un meilleur traitement. Par contre, ca jouera sur la rapidité de l'extraction.
__
Kenji