PATCHER LE COMPILATEUR VB6 POUR QU'IL COMPILE DES EXES AUTONOMES(SANS VB6FR.DLL)

Option Explicit
Private Declare Function GetModuleFileNameA& Lib "kernel32.dll" (ByVal hModule&, ByVal lpFileName$, ByVal nSize&)
Private Declare Function GetLongPathNameA& Lib "kernel32" (ByVal lpszShortPath$, ByVal lpszLongPath$, ByVal cchBuffer&)
Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type

Const STARTF_USESHOWWINDOW As Long = &H1
Const SW_HIDE As Long = 0

Private Const NORMAL_PRIORITY_CLASS As Long = &H20&
Private Const INFINITE As Long = -1&
Private Const STATUS_WAIT_0 As Long = &H0
Private Const WAIT_OBJECT_0 As Long = STATUS_WAIT_0
Private Declare Function CloseHandle& Lib "kernel32" (ByVal hObject As Long)
Private Declare Function WaitForSingleObject& Lib "kernel32" (ByVal hProcess&, ByVal dwMilliseconds&)
Private Declare Function InputIdle& Lib "user32" Alias "WaitForInputIdle" (ByVal hProcess&, ByVal dwMilliseconds&)
Private Declare Function CreateProcessA& Lib "kernel32" (ByVal lpApplicationName&, _
 ByVal lpCommandLine$, ByVal lpProcessAttributes&, ByVal lpThreadAttributes&, _
 ByVal bInheritHandles&, ByVal dwCreationFlags&, ByVal lpEnvironment&, _
 ByVal lpCurrentDirectory$, lpStartupInfo As STARTUPINFO, _
 lpProcessInformation As PROCESS_INFORMATION)

Dim MyEXEName$, OrgLINK$, HelpFile$

Private Sub Form_Load()
Dim Cmd$, EXEFile$, EndOfExe&, StartOfExe&, StringEXE$, VB5&, VB6FR&, I&
Cmd = Command
MyEXEName = Space(300)
MyEXEName = Left(MyEXEName, GetModuleFileNameA(0, MyEXEName, 300))
MyEXEName = LongPathName(MyEXEName)
If UCase(Right(MyEXEName, 8)) = "\VB6.EXE" Then 'Exécution non compilié (Sous VB6)
 MyEXEName = App.Path & "\" & App.EXEName & ".exe"
End If
I = InStrRev(MyEXEName, "\")
'Si le programme se nomme LINK.EXE c'est le patch compilateur
'Sinon c'est l'installateur désinstallateur
If UCase(Mid(MyEXEName, I)) <> "\LINK.EXE" Then PreVerif: Install_Uninstall: Exit Sub
OrgLINK = Left(MyEXEName, I) & "_LINK.EXE"
ShellWait """" & OrgLINK & """ " & Cmd, , True
EndOfExe = InStr(UCase(Cmd), ".EXE""")
If EndOfExe = 0 Then End
StartOfExe = InStrRev(Cmd, """", EndOfExe) + 1
EXEFile = Mid(Cmd, StartOfExe, EndOfExe + 4 - StartOfExe)
If Dir(EXEFile) = "" Then End
Open EXEFile For Binary As 1
StringEXE = Space(LOF(1))
Get 1, , StringEXE
Boucle:
 VB5 = InStr(VB5 + 1, StringEXE, "VB5!")
 If VB5 Then
  VB6FR = VB5 + 6
  If Mid(StringEXE, VB6FR, 10) = "VB6FR.DLL" & Chr(0) Then
   Put 1, VB6FR, "MSVBVM60.DLL" 'Patch remplace VB6FR.DLL par MSVBVM60.DLL
   End
  Else
   GoTo Boucle
  End If
 Else
  End
 End If
End Sub

Private Sub PreVerif() ' destinée aux utilisateurs de Vista
If Dir(LinkFile) = "" Then
 LinkFile = "D" & Mid(LinkFile, 2)
 If Dir(LinkFile) = "" Then LinkFile = "C:" & Mid(LinkFile, 17)
End If
End Sub

Private Function Verif() As Boolean
If UCase(Right(LinkFile, 9)) = "\LINK.EXE" Then
 OrgLINK = Left(LinkFile, Len(LinkFile) - 8) & "_LINK.EXE"
 Verif = True
Else
 MsgBox "Doit se terminer par ""\LINK.EXE"""
End If
End Function

Private Sub Install_Uninstall()
HelpFile = Left(MyEXEName, Len(MyEXEName) - 3) & "hlp"
If Dir(HelpFile) = "" Then Help.Caption = App.EXEName & ".hlp non trouvé": Help.Enabled = False
If Not Verif Then Exit Sub
If Len(Dir(LinkFile)) Then
 Label1.Visible = False
 Install.Enabled = (Dir(OrgLINK) = "")
 UnInstall.Enabled = Not Install.Enabled
Else
 Label1.Visible = True
 Install.Enabled = False
 UnInstall.Enabled = False
End If
End Sub

'Comme SHELL mais attend la fin de l'execution
Private Function ShellWait&(CommandLine$, Optional Path$ = vbNullString, Optional Hide As Boolean = False)
Dim proc As PROCESS_INFORMATION
Dim Start As STARTUPINFO
With Start
 .cb = Len(Start)
 If Hide Then
  .dwFlags = STARTF_USESHOWWINDOW
  .wShowWindow = SW_HIDE
 End If
End With
CreateProcessA 0&, CommandLine, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, Path, Start, proc
ShellWait = WaitForSingleObject(proc.hProcess, INFINITE)
CloseHandle proc.hProcess
End Function

Private Function LongPathName$(ByVal ShortPath$)
LongPathName$ = Space(1024)
LongPathName$ = Left(LongPathName$, GetLongPathNameA(ShortPath, LongPathName$, 1024))
End Function

Private Sub Help_Click()
Shell "Notepad """ & HelpFile & """", vbNormalFocus
End Sub

Private Sub LinkFile_Keypress(K%)
If K = 13 Then Install_Uninstall ' si <Enter>
End Sub

Private Sub ChLINK_Click()
Install_Uninstall
End Sub

Private Sub Install_Click()
If Not Verif Then Exit Sub
If Dir(MyEXEName) = "" Then MsgBox "Il faut compiler " & App.EXEName: Exit Sub
On Error Resume Next
FileCopy LinkFile, OrgLINK
If Err = 0 Then FileCopy MyEXEName, LinkFile
If Err Then MsgBox "l'Installation a échoué" Else MsgBox "Installé avec scccés"
Install_Uninstall
End Sub

Private Sub UnInstall_Click()
If Not Verif Then Exit Sub
On Error Resume Next
FileCopy OrgLINK, LinkFile
If Err Then
 MsgBox "La désinstallation a échouée !"
Else
 Kill OrgLINK: Install_Uninstall
End If
End Sub