Suppresseur de la dépendace à vb6fr.dll rend les exes vb6 autonomes

Télécharger le projet
Commenter

Description

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
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (deleplace)