Redirige la dépendance à VB6FR.DLL pour les EXEs VB6
vers MSBVVM60.DLL dont ils sont déja dépendants
et qui est présent sur tous les PC
donc une indépendance au DLLs
Sous forme d'un explorateur convivial et informatif
il permet de patcher d'un click autant d'EXEs que vous voulez
conservation ou non des dates originales
Réversible en cas de besoin
Source / Exemple :
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
Conclusion :
Utile, voire indispensable
Toutes vos applis autonomes
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.