Extracteur d' icônes et d'images des exes et frx vb6

Soyez le premier à donner votre avis sur cette source.

Vue 4 776 fois - Téléchargée 612 fois

Description

Extracteur d' Icônes et d'Images des Exes et Frx Vb6
Permet de retrouver les icônes et images originales
de vos propres projets ou ceux des autres des EXEs ou FRX vb6

Source / Exemple :


Option Explicit
Private Declare Function GlobalLock& Lib "kernel32" (ByVal HMem&)
Private Declare Sub GlobalFree Lib "kernel32" (ByVal HMem&)
Private Declare Function GlobalAlloc& Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long)
Private Declare Sub GlobalUnlock Lib "kernel32" (ByVal HMem&)
Private Declare Function OleLoadPicture& Lib "olepro32" (pStream As Any, ByVal lSize&, ByVal fRunmode&, riid As Any, ppvObj As Any)
Private Declare Function CLSIDFromString& Lib "ole32" (ByVal lpsz As Any, pclsid As Any)
Private Declare Function CreateStreamOnHGlobal& Lib "ole32" (ByVal hGlobal&, ByVal fDeleteOnRelease&, ppstm As Any)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal Length&)
Private Declare Sub DeleteFileA Lib "kernel32" (ByVal FileName$)
Dim Donot%, buf() As Byte, ba$, File$, Path$, PFile$
Dim WM%, HM%, NXM%, WMS%, HMS%, LM%

Private Sub Dir1_click()
On Error Resume Next
File1.Path = Dir1.List(Dir1.ListIndex)

End Sub

Private Sub Drive1_Change()
On Error Resume Next
Dir1.Path = UCase(Left(Drive1, 2)) & "\"
If Err Then Exit Sub
File1.Path = Dir1.Path
End Sub

Private Sub ef_Click(I%)
If Not Donot Then
 Donot = -1
 Dim J%
 For J = 0 To 2: ef(J) = -(I = J): Next
 File1.Pattern = ef(I).Caption
 Donot = 0
End If
End Sub

Private Sub Extract_Click(Index%)
Dim I%, b() As Byte
For I = 0 To List1.ListCount - 1
 If Index Or List1.Selected(I) Then Extract2Buffer I, b: Buf2File PF(Path, List1.List(I)), b
Next
End Sub

Private Sub File1_Click()
File = File1.FileName
LoadF File
End Sub

Private Function PF$(P$, F$)
If Right(P, 1) = "\" Then PF = P & F Else PF = P & "\" & F
End Function

Private Sub LoadF(F$)
Dim I%
Path = File1.Path: File = F
PFile = PF(Path, File)
List1.Clear: For I = 0 To 47: Picture2(I).Visible = False: Next: Picture1.Visible = False
On Error Resume Next
If FileLen(PFile) = 0 Then Exit Sub
If Err Then Exit Sub
Open PFile For Binary As 1
If Err Then Close 1: Exit Sub
On Error GoTo 0
ReDim buf(LOF(1) - 1): ba = Space(LOF(1))
Get 1, , buf: Get 1, 1, ba
Close 1
If ico Then exico
If bmp Then exbmp
If gif Then exgifjpg "GIF8", &H3B00, ".gif"
If jpg Then exgifjpg Chr(255) & Chr(&HD8), &HD9FF, ".jpg"
ba = ""
End Sub
Private Sub exico()
Dim I&, J&, L&, A$
I = 2: A = String(4, 0) & Chr(1) & Chr(0)
bcl:
I = InStr(I + 1, ba, A)
If I = 0 Then Exit Sub
I = I + 1
L = buf(I - 4) + 256& * buf(I - 3)
If I + L <= Len(ba) Then
 If L > 765 And buf(I + 4) > 0 And buf(I + 6) > 15 And buf(I + 6) = buf(I + 7) Then
  AddList I, ".ico": I = I + L - 1
 End If
End If
GoTo bcl

End Sub
Private Sub exbmp()
Dim I&, J&, L&, A$
I = 3: A = Chr(0) & "BM"
bcl:
I = InStr(I + 1, ba, A)
If I = 0 Then Exit Sub
If Mid(ba, I - 3, 4) = Mid(ba, I + 3, 4) Then
 CopyMemory L, buf(I - 4), 4
 If I + L <= Len(ba) Then AddList I, ".bmp": I = I + L - 1
End If
GoTo bcl
End Sub

Private Sub exgifjpg(ID$, FN%, suf$)
Dim I&, J&, L&, A$, w%
I = 3: A = Chr(0) & ID
bcl:
I = InStr(I + 1, ba, A)
If I = 0 Then Exit Sub
CopyMemory L, buf(I - 4), 4
If I + L <= Len(ba) Then
 CopyMemory w, buf(I + L - 2), 2: If w = FN Then AddList I, suf: I = I + L - 1
End If
GoTo bcl
End Sub
Private Sub AddList(I&, suf$)
Dim b() As Byte
List1.AddItem Replace(File, ".", "_") & "_0x" & hex6(I) & suf
Extract2Buffer List1.ListCount - 1, b
If LoadPic(Picture3, b) Then loadPic2 List1.ListCount - 1
End Sub

Private Function hex6$(I&)
hex6 = Mid(Hex(I Or &H7F000000), 3)
End Function
Private Sub Form_Load()
For LM = 1 To 47: Load Picture2(LM): Next
ef_Click 2
LM = List1.Left + List1.Width
WM = (ScaleWidth - LM) \ 6
WMS = WM - 4 * Screen.TwipsPerPixelX
HM = WM: HMS = WMS

End Sub

Private Sub List1_Click()
View List1.ListIndex
End Sub

Private Sub Extract2Buffer(J%, b() As Byte)
Dim I&, L&, F$
F = List1.List(J)
I = Val("&H" & Mid(F, Len(File) + 4, 6) & "&")
CopyMemory L, buf(I - 4), 4
ReDim b(L - 1)
CopyMemory b(0), buf(I), L
End Sub

Private Function LoadPic%(P As Object, b() As Byte)
Dim Ipic As IPicture, vStream As IUnknown, vIID(15) As Byte, vMem&, Vptr&, Vsize&, PTS&
PTS = VarPtr(b(0)): Vsize = UBound(b) + 1
vMem = GlobalAlloc(2, Vsize)
If vMem = 0 Then Exit Function
Vptr = GlobalLock(vMem)
If Vptr Then
 CopyMemory ByVal Vptr, ByVal PTS, Vsize
 GlobalUnlock vMem
 If CreateStreamOnHGlobal(vMem, 1, vStream) = 0 Then
  If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), vIID(0)) = 0 Then
   LoadPic = (OleLoadPicture(ByVal ObjPtr(vStream), Vsize, 0, vIID(0), Ipic) = 0)
  End If
 End If
End If
GlobalFree vMem
If LoadPic Then Set P.Picture = Ipic Else P.Picture = LoadPicture()
End Function

Private Sub Buf2File(F$, b() As Byte)
Dim h%: h = FreeFile: DeleteFileA F: Open F For Binary As h: Put h, , b: Close h
End Sub

Private Sub loadPic2(I%)
Dim w%, h%
If I > 47 Then Exit Sub
Picture2(I).Left = LM + (I Mod 6) * WM
Picture2(I).Top = HM * (I \ 6)
Debug.Print I, Picture2(I).Height
Picture2(I).Cls: Picture2(I) = LoadPicture()
If Picture3.ScaleHeight <= HMS And Picture3.ScaleWidth <= WMS Then
 Picture2(I).Picture = Picture3.Picture
Else
 w = WMS: h = w * Picture3.Height / Picture3.Width
 If h > HMS Then h = HMS: w = h * Picture3.Width / Picture3.Height
 Picture2(I).Width = w + 4 * Screen.TwipsPerPixelX
 Picture2(I).Height = h + 4 * Screen.TwipsPerPixelY
 Picture2(I).PaintPicture Picture3.Picture, 0, 0, w, h, 0, 0, Picture3.Width, Picture3.Height
End If
Picture2(I).Visible = True
End Sub

Private Sub Picture1_Click()
Picture1.Visible = False
End Sub
Private Sub Picture2_Click(I%)
View I
End Sub

Private Sub View(I%)
Dim b() As Byte
Extract2Buffer I, b
LoadPic Picture1, b: Picture1.Visible = True
If b(0) = 0 Then Icon = Picture1.Picture
End Sub

Conclusion :


Peut-être pas assez explicite
mais trés utile

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

atrocity
Messages postés
14
Date d'inscription
jeudi 1 octobre 2009
Statut
Membre
Dernière intervention
21 octobre 2010
1 -
Bonjour, je vois que l'exécution est très rapide.
Effectivement, il manque une option, la sauvegarde du contenue récupérée.
cs_Cheval
Messages postés
81
Date d'inscription
dimanche 21 juillet 2002
Statut
Membre
Dernière intervention
11 octobre 2015
-
M'excuse mal expliqué.

Plutot que les images et icones se copient dans le repertoire ou se trouve le fichier. Pouvoir choisir le repertoire ou ton appli dit copier.
cs_yves29
Messages postés
34
Date d'inscription
dimanche 11 mai 2003
Statut
Membre
Dernière intervention
20 juin 2011
-
Très bien. Je ne comprend le commentaire précédent, quand on extrait les images et icones, on en fait ce que l'on veut.
cs_Cheval
Messages postés
81
Date d'inscription
dimanche 21 juillet 2002
Statut
Membre
Dernière intervention
11 octobre 2015
-
L'extraction se passe bien dommage que l'on ne peut pas copier les icones ou images!!!!

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.