Soyez le premier à donner votre avis sur cette source.
Vue 7 125 fois - Téléchargée 1 262 fois
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
17 juin 2010 à 17:45
En fait, je ne développe pas sur une machine dont je ne suis pas Administrateur. Je développe à la maison et installe ensuite mes programmes au boulot. Et là, le nouveau PC est en compte limité.
Faudra certainement que je revois ça avec le responsable parce que ça me gonfle (même l'heure du PC ne peut être modifiée).
16 juin 2010 à 21:33
12 juin 2010 à 18:18
Dès lors, est-ce qu'en mettant les OCX et DLL dans le même répertoire que l'EXE sur une clé USB, il me sera possible d'utiliser le programme ?
2 mars 2009 à 14:43
à VB6FR.DLL vers MSDMO.DLL mais vers MSVBVM60.DLL
c'est plus logique, l'EXE est déja dépendant de MSVBVM60.DLL
et surtout cela supprime les problèmes constatés
différence avant et après patch:
les messages d'erreurs critiques(progamme planté)
sont en Anglais au lieu d'être en Français
28 févr. 2009 à 01:15
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.