Créateur de lanceur de logiciel dans un dossier temporaire en un seul exe comprimé(7z)

Télécharger le projet
Commenter

Description

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
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)