destiné au programmeur qui veulent faire tourner leur application
sur n(importe quel PC administrateur ou non
sans installation en un seul fichier exécutable
il faut mettre tous les fichiers dans une archive.7z (7zip)
puis lancer Zexe (le créateur de lanceur)
optionnellement cliquer sur un fichier .ico pour changer les icones du lanceur
Puis cliquer sur l'archive.7z, vérifier les noms
puis cliquer sur création
Source / Exemple :
Option Explicit
Private Type tagINDIVIDUALINFO
dwOriginalSize As Long
dwCompressedSize As Long
dwCRC As Long
uFlag As Long
uOSType As Long
wRatio As Integer
wDate As Integer
wTime As Integer
szFilename As String * 513
dummy1 As String * 3
szAttribute As String * 8
szMode As String * 8
End Type
Private Declare Function SevenZipOpenArchive Lib "7-zip32.DLL" (ByVal hwnd As Long, ByVal szFilename As String, ByVal dwMode As Long) As Long
Private Declare Function SevenZipCloseArchive Lib "7-zip32.DLL" (ByVal harc As Long) As Long
Private Declare Function SevenZipFindFirst Lib "7-zip32.DLL" (ByVal harc As Long, ByVal szWildName As String, lpSubInfo As tagINDIVIDUALINFO) As Long
Private Declare Function SevenZipFindNext Lib "7-zip32.DLL" (ByVal harc As Long, lpSubInfo As tagINDIVIDUALINFO) As Long
Private Declare Function GetSysColor& Lib "user32" (ByVal nIndex&)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal Length&)
Dim Head(122367) As Byte
Dim ADIco()
Dim CFG$, Cree$
'Désolé cette source est plus éfficace que pédagogique
Private Sub Form_Load()
'extraction des données binaires (comprimées GIF) de Picture1(8).Picture
Dim F$, I&, X(15) As Byte, Y(255) As Byte
SavePicture Picture1(8).Picture, TMP
Open TMP For Binary As 1: Get 1, &H77, Head: Close 1: Kill TMP
'décryptage des données
For I = 0 To 15: X(I) = "&H" & Mid("49E750183C26FDBA", I + 1, 1): Next
For I = 0 To 255: Y(I) = X(I And 15) + 16 * X(I \ 16): Next
For I = 0 To 122367: Head(I) = Y(Head(I)): Next
'initialisations
HeaderFile = PathFile(App.Path, "7zS.sfx")
CFG = Config: If Right(CFG, 2) = vbCrLf Then CFG = Left(CFG, Len(CFG) - 2)
Cree = Create.Caption
EXEs = App.EXEName & ".exe"
SFXFile = "Lanceur_" & EXEs: File7z = titre & ".7z"
'Adresse des 9 icônes du lanceur
ADIco = Array(&H17498, &H18350, &H19F08, &H17780, &H18BF8, &H1AFB0, &H17370, &H17DE8, &H19AA0)
'test intégrité des données et affichage des 9 icones
For I = 0 To 8
If Head(ADIco(I)) <> 40 Then MsgBox "Données Binaires incorrectes !": End
Exicon I, Picture1(I)
Next
End Sub
Private Sub Create_Click()
Dim Id%, L&, T$, A$, P&, B() As Byte
T = SFXFile: If Left(T, 1) <> "\" And Mid(T, 2, 1) <> ":" Then T = PathFile(File1.Path, T)
If Len(File7z) Then
If Len(Dir(T)) Then If MsgBox("Ecrase " & T & " ?", vbYesNo) <> vbYes Then Exit Sub
If Len(Dir(PathFile(File1.Path, File7z))) Then
Open PathFile(File1.Path, File7z) For Binary As 1
Get 1, , Id: Seek 1, 1
If Id = &H7A37 Then
Open T For Output As 2: Close 2
Open T For Binary As 2
Put 2, , Head
A = Config: If Right(A, 2) = vbCrLf Then A = Left(A, Len(A) - 2)
Put 2, , A
L = LOF(1)
If L > 1048576 Then
ReDim B(1048577)
While L > 1048576
Get 1, , B: Put 2, , B
L = L - 1048576
Wend
End If
ReDim B(L - 1): Get 1, , B: Put 2, , B
Else
MsgBox "Invalid " & File7z
End If
Close
File1.Refresh
End If
End If
End Sub
Private Sub Dir1_CLick()
File1.Path = Dir1.List(Dir1.ListIndex)
End Sub
Private Sub Drive1_Change()
Dir1.Path = UCase(Left(Drive1, 2)) & "\"
File1.Path = Dir1.Path
End Sub
Private Sub File1_Click()
Dim PF$, F$, S$, B() As Byte, L&, N%, AD&, I%, W%, LI%, M%, LP%
F = File1.FileName: S = UCase(Right(F, 1))
PF = PathFile(File1.Path, F)
If S = "Z" Then
If FindEXEs(PF) Then
File7z = F: F = UCase(Left(F, Len(F) - 2)) & "EXE"
List1.Visible = (List1.ListCount > 1 And UCase(EXEs) <> F): List1.Height = 60 + 195 * List1.ListCount
SFXFile = "Lanceur_" & UnBS(EXEs)
If InStr(EXEs, "\") Then TextBug.Visible = True
End If
End If
If S = "O" Then
L = FileLen(PF)
For I = 0 To 7
W = 32 + 16 * (I \ 4): M = W / 4 - 4
N = Asc(Mid("48HP", 1 + (I And 3))) - 48
If N <= 8 Then LP = 4 * 2 ^ N Else LP = 0
LI = 62 + LP + W * (N * W / 8 + M)
If LI = L Then ConvAll PF, I: Exit For
Next
End If
End Sub
Private Sub ToHead(I%, B() As Byte)
CopyMemory Head(ADIco(I)), B(22), UBound(B) - 21
LoadPic Picture1(I), B
End Sub
Private Sub LoadPic(P As PictureBox, B() As Byte)
Dim L&(12), D() As Byte, C&, BG(2) As Byte, S&, I&, J&, Alpha!, Nalpha!
If B(0) = 0 And B(&H24) = 32 Then
L(2) = 54: L(3) = 40: L(4) = B(6): L(5) = B(7): L(6) = &H200001
L(0) = 54 + L(4) * 4 * L(5): ReDim D(3, L(4) * L(5) - 1)
C = P.BackColor: If C < 0 Then C = GetSysColor(C And 255)
BG(0) = C \ 65536
BG(1) = (C And &HFF00&) \ 256
BG(2) = C And 255&
S = 62
For I = 0 To UBound(D, 2)
Alpha = B(S + 3) / 255
Nalpha = 1 - Alpha
For J = 0 To 2
D(J, I) = Alpha * B(S + J) + Nalpha * BG(J)
Next
S = S + 4
Next
C = FreeFile
Open TMP For Binary As C: Put C, , &H4D42: Put C, , L: Put C, , D
Close C
Else
Buf2File TMP, B
End If
P.Picture = LoadPicture(TMP): Kill TMP
End Sub
Private Sub Buf2File(F$, B() As Byte)
Dim H%: H = FreeFile: Open F For Output As H: Close H
Open F For Binary As H: Put H, , B: Close H
End Sub
Private Sub ConvAll(F$, I%)
Dim B() As Byte, D() As Byte, J%
Open F For Binary As 1: ReDim B(LOF(1) - 1): Get 1, , B: Close 1
If I Mod 4 > 1 Then
If I Mod 4 = 2 Then B24To32 B Else I = I - 1
End If
I = I - I \ 4: J = I Mod 3
ToHead I, B
If J < 2 Then
If J Then
D = B: I256To16 D: ToHead I - 1, D
Else
I16to256 B: I = I + 1: ToHead I, B
End If
I = I + 1: B8To32 B: ToHead I, B
Else
D = B: B32To8 D: ToHead I - 1, D
I256To16 D: ToHead I - 2, D
End If
SizIco16 B, D ' 32 ou 48 -> 16x16
ToHead 8, D
B32To8 D: ToHead 7, D
I256To16 D: ToHead 6, D
SizIco B, D ' 32<->48
I = 3 * (1 - I \ 3) + 2
ToHead I, D
B32To8 D: ToHead I - 1, D
I256To16 D: ToHead I - 2, D
End Sub
Private Sub SizIco(B() As Byte, D() As Byte)
Dim WS%, WT%, WU%, Wc%, I%, S%, T%, M%, X%, Y%, C%
WS = B(6): WT = WS Xor 16: WU = IIf(WT = 32, 4, 8)
ReDim D(61 + 4 * WT * WT + WT * WU)
For I = 0 To 61: D(I) = B(I): Next
D(6) = WT
D(7) = WT
I = UBound(D) - 21
D(14) = I And 255: D(15) = I \ 256
D(26) = WT: D(30) = 2 * WT
T = 62
If WT = 48 Then
For Y = 62 To 61 + 4 * WS * WS Step 8 * WS
For S = Y To Y + 127 Step 8
For C = S To S + 3
D(T) = B(C)
D(T + 4) = (1 + B(C) + B(C + 4)) \ 2
D(T + 8) = B(C + 4)
D(T + 192) = (1 + B(C) + B(C + 128)) \ 2
D(T + 196) = (2 + B(C) + B(C + 4) + B(C + 128) + B(C + 132)) \ 4
D(T + 200) = (1 + B(C + 4) + B(C + 132)) \ 2
D(T + 384) = B(C + 128)
D(T + 388) = (1 + B(C + 128) + B(C + 132)) \ 2
D(T + 392) = B(C + 132)
T = T + 1
Next C
T = T + 8
Next S
T = T + 384
Next Y
Else
For Y = 62 To 61 + 4 * WT * WT Step 8 * WT
For S = Y To Y + 127 Step 8
For C = S To S + 3
D(C) = (4 + 4 * B(T) + 2 * B(T + 4) + 2 * B(T + 192) + B(T + 196)) \ 9
D(C + 4) = (4 + 4 * B(T + 8) + 2 * B(T + 4) + 2 * B(T + 200) + B(T + 196)) \ 9
D(C + 128) = (4 + 4 * B(T + 384) + 2 * B(T + 388) + 2 * B(T + 192) + B(T + 196)) \ 9
D(C + 132) = (4 + 4 * B(T + 392) + 2 * B(T + 388) + 2 * B(T + 200) + B(T + 196)) \ 9
T = T + 1
Next C
T = T + 8
Next S
T = T + 384
Next Y
End If
T = 65
For Y = UBound(D) - WT * WU + 1 To UBound(D) Step WU
For X = Y To Y + Wc
M = 0
For T = T To T + 28 Step 4
M = 2 * M + Sgn(D(T))
Next
D(X) = 255 - M
Next
Next
End Sub
Private Sub SizIco16(B() As Byte, D() As Byte)
Dim WS%, I%, S%, T%, M%, X%, Y%, C%, DX%
ReDim D(1149)
WS = B(6)
For X = 0 To 61: D(X) = B(X): Next
D(6) = 16: D(7) = 16: D(26) = 16: D(30) = 32
D(14) = &H68: D(15) = 4
T = 62: DX = WS \ 4 - 4
For Y = 62 To 1085 Step 64
For S = Y To Y + 63 Step 4
For C = S To S + 3
If WS = 48 Then
D(C) = (4 + B(T) + B(T + 4) + B(T + 8) + B(T + 192) + B(T + 196) + B(T + 200) + B(T + 384) + B(T + 388) + B(T + 392)) \ 9
Else
D(C) = (2 + B(T) + B(T + 4) + B(T + 128) + B(T + 132)) \ 4
End If
T = T + 1
Next C
T = T + DX
Next S
T = T + DX * WS
Next Y
T = 65
For Y = 1086 To 1149 Step 4
For X = Y To Y + 1
M = 0
For T = T To T + 28 Step 4
M = 2 * M + Sgn(D(T))
Next
D(X) = 255 - M
Next
Next
End Sub
Private Sub B24To32(B() As Byte)
Dim W%, WU%, H%, M24%, M32, LM%, Y%, D%, Wc, T&, M%, S%, X%
W = B(6): H = B(7)
WU = IIf(W = 32, 4, 8): Wc = W \ 8 - 1
D = W * H
M24 = 62 + 3 * D: M32 = M24 + D
LM = H * WU
ReDim Preserve B(M32 + LM - 1)
S = M24 - 3: T = M32
For Y = M32 To M32 + LM - 1: B(Y) = B(Y - D): Next
For Y = Y - WU To M32 Step -WU
For X = Y + Wc To Y Step -1
M = B(X)
For S = S To S - 21 Step -3
T = T - 4
If M And 1 Then
B(T + 3) = 0: B(T + 2) = 0: B(T + 1) = 0: B(T) = 0
Else
B(T + 3) = 255: B(T + 2) = B(S + 2): B(T + 1) = B(S + 1): B(T) = B(S)
End If
M = M \ 2
Next
Next
Next
B(&H24) = 32: X = UBound(B) - 21: B(14) = X And 255: B(15) = X \ 256
End Sub
Private Sub I16to256(B() As Byte)
Dim I%, J%, U%, W%, WU%
J = 1086: B(&H24) = 8: U = UBound(B): W = B(6): WU = IIf(W > 32, 8, 4)
If W = 32 Then
ReDim Preserve B(2237)
For I = 638 To 765: B(I + 1472) = B(I): Next
For I = 126 To 637: B(J) = B(I) \ 16: B(J + 1) = B(I) And 15: J = J + 2: Next
Else
ReDim Preserve B(3773)
For I = 1278 To 1661: B(I + 2112) = B(I): Next
J = 3390
For I = 1277 To 126 Step -1: J = J - 2: B(J) = B(I) \ 16: B(J + 1) = B(I) And 15: Next
End If
For I = 126 To 1085: B(I) = 0: Next
B(&H36) = 0
B(&H37) = 0
I = W * (W + WU): B(&H2A) = I And 255: B(&H2B) = I \ 256
I = UBound(B) - 21: B(14) = I And 255: B(15) = I \ 256
End Sub
Private Sub I256To16(B() As Byte)
Dim U0%, U1%, U2%, D%, W%, WU%
Dim P16(3, 15), X(255) As Byte, I%, J%, Bu&, V&, R&, E&, xe&, P%, N%(255)
W = B(6): WU = (W \ 8 + 3) And &HFC
For I = 1086 To 1085 + W * W: N(B(I)) = N(B(I)) + 1: Next
For I = 62 To 1085 Step 4
If (B(I) Or B(I + 1) Or B(I + 2)) < 32 Then N((I - 62) \ 4) = 0
Next
For I = 1 To 15: R = 0: V = -1
For J = 0 To 255
If N(J) > R Then
R = N(J): V = J
End If
Next
If V = -1 Then Exit For
N(V) = 0: For J = 0 To 2: P16(J, I) = B(62 + 4 * V + J): Next
Next
U0 = UBound(B)
U2 = 125 + W * W \ 2
U1 = U2 + W * WU
I = U1 - 21: B(14) = I And 255: B(15) = I \ 256
P = 62
For I = 0 To 255
xe = 195075
For J = 0 To 15
Bu = CInt(B(P)) - P16(0, J)
V = CInt(B(P + 1)) - P16(1, J)
R = CInt(B(P + 2)) - P16(2, J)
E = Bu * Bu + V * V + R * R
If E < xe Then xe = E: X(I) = J
Next
P = P + 4
Next
J = 1086
For I = 126 To U2
B(I) = 16 * X(B(J)) + X(B(J + 1)): J = J + 2
Next
D = U0 - U1: For I = I To U1: B(I) = B(I + D): Next
For J = 0 To 3: For I = 0 To 15: B(62 + J + 4 * I) = P16(J, I): Next I, J
ReDim Preserve B(U1)
B(&H37) = 0
I = W * (W \ 2 + WU): B(&H2A) = I And 255: B(&H2B) = I \ 256: B(&H24) = 4
End Sub
Private Sub B32To8(B() As Byte)
Dim S() As Byte, I%, WM%, M&, P%, T%, W%, D%, J%, X%, Y%, MM%, NP%
S = B
NP = S(6)
M = 1086 + NP * NP: W = NP \ 8 - 1: WM = (W + 4) And &H7C
ReDim B(M + NP * WM - 1)
For I = 0 To 61: B(I) = S(I): Next
I = UBound(B) - 21: B(14) = I And 255: B(15) = I \ 256
B(&H24) = 8
For I = 0 To 215
T = 62 + 4 * I
B(T) = 51 * (I Mod 6)
B(T + 1) = 51 * ((I \ 6) Mod 6)
B(T + 2) = 51 * (I \ 36)
Next
T = 62: I = 1086
For X = M To UBound(B) Step WM
For J = X To X + W
MM = 0
For I = I To I + 7
MM = 2 * MM
If S(T + 3) > 127 Then
B(I) = (25 + S(T)) \ 51 + 6 * ((25 + S(T + 1)) \ 51) + 36 * ((25 + S(T + 2)) \ 51)
Else
MM = MM + 1
End If
T = T + 4
Next
B(J) = MM
Next
Next
End Sub
Private Sub B8To32(B() As Byte)
Dim S() As Byte, I%, WM%, M&, P%, T%, W%, D%, J%, NP%
S = B
NP = S(6)
If NP = 32 Then
ReDim B(4285): WM = 4: M = 4158: W = 3
Else
ReDim B(9661): WM = 8: M = 9278: W = 5
End If
For I = 65 To 1086 Step 4: S(I) = 255: Next
For I = 0 To 61: B(I) = S(I): Next
I = UBound(B) - 21: B(14) = I And 255: B(15) = I \ 256
B(&H24) = 32
T = 62
For I = 1086 To NP * NP + 1085
P = 62 + 4 * S(I)
For P = P To P + 3: B(T) = S(P): T = T + 1: Next
Next
D = T - I: T = 62
For I = I To UBound(S) Step WM
For J = I To I + W
B(J + D) = S(J): M = S(J)
For T = T To T + 28 Step 4
If M And 128& Then B(T) = 0: B(T + 1) = 0: B(T + 2) = 0: B(T + 3) = 0
M = 2 * M
Next
Next
Next
End Sub
Private Sub File1_DblClick()
If UCase(Right(File1.FileName, 1)) = "E" Then
ChDrive File1.Path: ChDir File1.Path
Shell File1.FileName, vbNormalFocus
End If
End Sub
Private Function Hex2Bin$(A$)
Dim I%
For I = 1 To Len(A) Step 2: Hex2Bin = Hex2Bin & Chr("&H" & Mid(A, I, 2)): Next
End Function
Private Function TMP$()
TMP = PathFile(Environ("TMP"), "Zexe.tmp")
End Function
Private Sub Exicon(I&, P As PictureBox)
Dim W%, AD&, NbBit&, LenIcon%, LenMask%, LenBitmap%, LenPalette, B() As Byte
AD = ADIco(I)
NbBit = Head(AD + 14)
W = Head(AD + 4)
LenMask = 4 * W * ((W + 31) \ 32)
LenBitmap = W * W * NbBit / 8
If NbBit < 24 Then LenPalette = 4 * 2 ^ NbBit
LenIcon = 62 + LenPalette + LenBitmap + LenMask
ReDim B(LenIcon - 1)
B(2) = 1
B(4) = 1
B(6) = W
B(7) = W
CopyMemory B(14), LenIcon - 22, 2
B(18) = 22
CopyMemory B(22), Head(AD), LenIcon - 22
W = W * Screen.TwipsPerPixelX
P.Width = W
P.Height = W
LoadPic P, B
End Sub
Private Sub File2Buf(F$, B() As Byte)
Dim H%
If Len(Dir(F)) Then H = FreeFile: Open F For Binary As H: ReDim B(LOF(H) - 1): Get H, , B: Close H
End Sub
Private Function PathFile$(P$, F$)
PathFile = Replace(P & "\" & F, "\\", "\")
End Function
Private Sub Save7zS_SFX_Click()
Buf2File HeaderFile, Head
End Sub
Private Sub TextBug_Click()
TextBug.Visible = False
End Sub
Private Sub titre_Change()
Config = Replace(Replace(CFG, "£", titre), "µ", EXEs)
Create.Caption = Cree & File7z & " " & SFXFile
End Sub
Private Sub EXEs_Change()
Dim A$: A = UnBS(EXEs)
titre = Left(A, Len(A) - 4)
titre_Change
End Sub
Private Sub EXEs_Click()
EXEs_Change
End Sub
Private Sub EXEs_GotFocus()
List1.Visible = False
End Sub
Private Sub List1_Click()
EXEs = List1.List(List1.ListIndex)
List1.Visible = False
End Sub
Private Sub File7z_Change()
Create.Caption = Cree & Guillemet(File7z) & " " & Guillemet(SFXFile)
Label13 = "Créer le lanceur " & Guillemet(SFXFile) & " (commande DOS équvalente)"
End Sub
Private Sub Sfxfile_Change()
File7z_Change
End Sub
Private Function Guillemet(F$)
If InStr(F, " ") Then Guillemet = """" & F & """" Else Guillemet = F
End Function
Private Function FindEXEs%(Archive$)
Dim udtINDIVIDUALINFO As tagINDIVIDUALINFO
Dim lngArcHandle&, A$, F$, I%
lngArcHandle = SevenZipOpenArchive(Me.hwnd, Archive, 0)
If lngArcHandle <> 0 Then
If SevenZipFindFirst(lngArcHandle, "*.exe", udtINDIVIDUALINFO) = 0 Then
EXEs.Clear: List1.Clear: FindEXEs = -1
Do
A = Left$(udtINDIVIDUALINFO.szFilename, InStr(udtINDIVIDUALINFO.szFilename, vbNullChar) - 1)
EXEs.AddItem A: List1.AddItem A
Loop While SevenZipFindNext(lngArcHandle, udtINDIVIDUALINFO) = 0
EXEs = EXEs.List(0)
A = UnBS(Archive)
A = UCase(Left(A, Len(A) - 2)) & "EXE"
For I = 0 To EXEs.ListCount - 1
If UCase(EXEs.List(I)) = A Then List1.Selected(I) = True: GoTo fnd
Next
A = "\" & A
For I = 0 To EXEs.ListCount - 1
F = EXEs.List(I)
If UCase(Right(F, Len(A))) = A Then List1.Selected(I) = True: GoTo fnd
Next
A = Mid(A, 2, Len(A) - 5)
For I = 0 To EXEs.ListCount - 1
F = EXEs.List(I)
If InStr(Mid(F, InStrRev(F, "\") + 1), A) Then List1.Selected(I) = True: GoTo fnd
Next
fnd:
End If
SevenZipCloseArchive lngArcHandle
If Not FindEXEs Then MsgBox F & " ne contiend pas d'EXE!"
Else
MsgBox "Format de " & F & " non Reconnu !"
End If
End Function
Private Function UnBS$(F$)
UnBS = Mid(F, InStrRev(F, "\") + 1)
End Function
Conclusion :
Fonctionnement parfait quelque soit le language code source
l'unique fichier créé est plus petit qu'un zip.totalement autonome
l'execution décomprime tout dans un dossier temporaire sous %TMP%
à la fin du programme tout est effacé. Uu +: le choix des icônes
Programmeurs en VB6:
voir aussi mes sources sur la suppression de la dépendance
à VB6FR.DLL ainsi que VB6 bilingue Français-Anglais
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.