SUPPRESSEUR DE LA DÉPENDACE À VB6FR.DLL REND LES EXES VB6 AUTONOMES

Option Explicit
'*******************************************************
'* RENDEZ VOUS EXEs VB6 AUTONOMES, PLUS BESOIN DE DLL  *
'*                    DELEPLACE 2009                   *
'*******************************************************

'Ces déclaration pour pouvoir redater les fichiers modifiés
Private Type FILETIME
 LowDateTime As Long
 HighDateTime As Long
End Type
Private Const G_READ = &H80000000, G_WRITE = &H40000000, F_SH_READ = 1, F_SH_W_R = 3
Private Const OPEN_EXISTING = 3
Private Declare Function CreateFileA& Lib "kernel32" (ByVal lpFileName$, ByVal dwDesiredAccess&, ByVal dwShareMode&, lpSecurityAttributes As Any, ByVal dwCreationDisposition&, ByVal dwFlagsAndAttributes&, ByVal hTemplateFile&)
Private Declare Sub SetFileTime Lib "kernel32" (ByVal hFile&, lpCreationTime As Any, lpLastAccessTime As Any, lpLastWriteTime As Any)
Private Declare Sub GetFileTime Lib "kernel32" (ByVal hFile&, cree As FILETIME, access As FILETIME, modif As FILETIME)
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hObject&)

Dim Path1$, DoNot%, IClick%
Dim cree As FILETIME, Acces As FILETIME, modif As FILETIME

Private Sub Form_Load()
'Affiche les Infos sur les EXEs VB6 dans le dossier courant
RefreshFile File1.Path
End Sub

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

Private Sub Dir1_Click()
On Error Resume Next
'Affiche les Infos sur les EXEs VB6 dans le nouveau dossier
RefreshFile Dir1.List(Dir1.ListIndex)
End Sub

Private Sub RefreshFile(Path$)
Dim I%, INF$
Text2.Visible = False
On Error Resume Next
File1.Path = Path
If Len(Path) > 3 Then Path1 = Path & "\" Else Path1 = Path
If Err Then Exit Sub
MousePointer = 11 'Sablier
File1.Refresh 'File1 est caché, les seul fichiers identifiés comme VB6
List1.Clear   'seront affichés dans List1
Text1 = ""
For I = 0 To File1.ListCount - 1
INF = Info(File1.List(I))
If Len(INF) Then List1.AddItem INF
Next
If List1.ListCount Then List1.Selected(0) = True
MousePointer = 0 ' fin du sablier
End Sub

Private Function Info$(File$)
'renvoie le NomduFichier,l'adresse et le nom de la DLL si identifié comme VB6
Dim I&, J&, A$, B$
On Error Resume Next
If Len(Dir(Path1 & File)) Then 'vérifie la présence du fichier
 'La longueur des EXEs VB6 est tjs multiple de 4096 . pourquoi ?
 If FileLen(Path1 & File) And &HFFF& Then Exit Function
 Open Path1 & File For Binary As 1
 If Err Then Exit Function
 A = Space(LOF(1)): Get 1, , A: Close 1 'tout le fichier est dans la chaine A$
bcl: I = InStr(I + 1, A, "VB5!") 'localise le nom de la DLL
 If I = 0 Then Exit Function
 B = RTrim(Replace(Mid(A, I + 6, 12), Chr(0), " "))
 If Right(B, 4) <> ".DLL" Then GoTo bcl
 J = 50 - Len(File): If J < 1 Then J = 1
 'Renvoie les infos
 Info = File & String(J, 32) & "0x" & Hex(I + 5) & " " & B
End If
End Function

Private Sub DLLReplace_Click(I%)
If Not DoNot% Then 'DoNot sert à bloquer un accés récurssif
 DoNot = -1
 DLLReplace(1 - I) = 0
 DLLReplace(I) = 1
 DoNot = 0
End If
End Sub

Private Sub Help_Click()
Text2.Visible = True
End Sub

Private Sub List1_Click()
IClick = List1.ListIndex
Text1 = List1.List(IClick)
End Sub

Private Sub RemplaceSEL_Click()
Dim I%
For I = 0 To List1.ListCount - 1
 If List1.Selected(I) Then IReplace I
Next
End Sub

Private Sub RemplaceALL_Click()
Dim I%
For I = 0 To List1.ListCount - 1
 IReplace I
Next
End Sub

Private Sub RemplaceTXT_Click()
If IClick < List1.ListCount Then IReplace IClick
End Sub

Private Sub IReplace(I%) ' Patcher List1(I)
Dim A$, F$, DLL$, OF7&, J%, K%, DL$, DLR$, DLV$
A = List1.List(I)
J = InStrRev(A, " 0x"): K = InStr(J + 1, A, " ")
OF7 = 1 + Val("&H" & Mid(A, J + 3, K - J - 3) & "&")
DLL = Mid(A, K + 1, 12)
DLL = Left(DLL, InStr(DLL & " ", " ") - 1)
DLL = DLL & String(12 - Len(DLL), 0)
: A = Left(A, K + 9)
DLV = DLLReplace(DLLReplace(1)).Caption
DLR = DLV & String(12 - Len(DLV), 0)
If DLL <> DLR Then
 F = Path1 & RTrim(Left(A, J))
 If SaveDates(F) Then 'sauve les dates du fichier et en même temps vérifi la présence
  Open F For Binary As 1
  DL = Space(12)
  Get 1, OF7, DL
  If DL = DLL Then
   On Error Resume Next
   Put 1, OF7, DLR
   If Err Then A = A & " Refusé" Else A = Left(A, K) & DLV
  Else
   A = A & " Erreur"
  End If
  Close 1
  If Redate Then Redates F
 Else
  A = A & " Non trouvé"
 End If
End If
List1.List(I) = A
If I = IClick Then Text1 = A
End Sub

Private Function SaveDates%(F$) 'sauve les dates du fichiers
Dim H&: H = CreateFileA(F, G_READ, F_SH_READ, ByVal 0&, OPEN_EXISTING, vbArchive, 0)
If H <> -1 Then GetFileTime H, cree, Acces, modif: CloseHandle H: SaveDates = -1
End Function

Private Sub Redates(F$) 'redate avec les dates initiales
Redate3 F, cree, Acces, modif
End Sub

Private Sub Redate3(F$, cree As FILETIME, Acces As FILETIME, modif As FILETIME)
Dim H&: H = CreateFileA(F, G_WRITE, F_SH_W_R, ByVal 0&, OPEN_EXISTING, 0, 0)
If H <> -1 Then SetFileTime H, cree, Acces, modif: CloseHandle H
End Sub