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
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.