Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0736: Selbstextrahierende EXE-Datei (SFX)

VB 5/6-Tipp 0736: Selbstextrahierende EXE-Datei (SFX)

 von Dario

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [11,33 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'--------- Anfang Projektgruppe SelfExtraction.vbg  ---------
'------------- Anfang Projektdatei Creator.vbp  -------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "txtContents"
' Steuerelement: Standarddialog-Steuerelement "dlgFiles"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

Private Sub Command1_Click()
   Dim Filename As String

   ' Dateiauswahldialog anzeigen
   With dlgFiles
      .InitDir = CurDir
      .ShowSave
      Filename = .Filename
   End With
   
   ' Schreiben
   
   ' Hier wird der Einfachheit wegen nur eine Zeichenfolge geschrieben
   ' Es können jedoch auch beliebige andere Daten geschrieben werden,
   ' wie z.B. Dateien für ein selbstextrahierendes Archiv
   
   If Filename <> "" Then
      Call sfx_Open(Filename, 101, "CUSTOM")                   ' Datei  schreiben
      Call sfx_Write(StrConv(txtContents.Text, vbFromUnicode)) ' Anhang schreiben (ByteArray)
      Call sfx_Close                                           ' Datei schließen
   End If

   ' Alles markieren
   With txtContents
      .SelStart = 0
      .SelLength = Len(.Text)
      .SetFocus
   End With
   
   ' Erfolgsmeldung
   Call MsgBox("Das Erstellen wurde erfolgreich ausgeführt", vbInformation)
End Sub

' Alles beenden
Private Sub Command2_Click()
   Call Unload(Me)
   Set frmMain = Nothing
End Sub

Private Sub Form_Load()

End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------- Anfang Modul "mdlCreate" alias mdlCreate.bas -------
Option Explicit


Private ff As Integer   ' Die Dateinummer

' Datei aus Resource schreiben
Public Sub sfx_Open(ByVal Filename As String, Optional ByVal ResID As Long = 101, Optional ByVal ResType As String = "CUSTOM")
   Dim Contents() As Byte
   
   ff = FreeFile
   
   Contents = LoadResData(ResID, ResType)                ' Inhalt laden
   
   Open Filename For Binary Access Write Shared As #ff   ' Öffnen
      Put #ff, , Contents                                ' Schreiben
End Sub

' Daten anhängen (ByteArray)
Public Sub sfx_Write(Data() As Byte)
   Put #ff, , Data
End Sub

' Schließen
Public Sub sfx_Close()
   Close #ff
End Sub
'-------- Ende Modul "mdlCreate" alias mdlCreate.bas --------
'-------------- Ende Projektdatei Creator.vbp  --------------
'--------------- Anfang Projektdatei SFX.vbp  ---------------
'-------- Anfang Formular "frmSFX" alias frmSFX.frm  --------
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "txtContents"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

' Die *.exe dieses Projektes wird als Basisexe in die Ressourcendatei von Creator.vbp geladen.

Private IsOK As Boolean ' Gab es Probleme?

' Den Anhang laden und anzeigen
Private Sub Command1_Click()
   txtContents.Text = StrConv(sfx_ReadAll, vbUnicode)
   Command1.Enabled = False
End Sub

' Programm schließen
Private Sub Command2_Click()
   Call Unload(Me)
   Set frmSFX = Nothing
End Sub

' Eigene Datei schließen, wenn es keine Probleme gab
Private Sub Form_Unload(Cancel As Integer)
   If IsOK Then Call sfx_Close
End Sub

' Eigene Datei öffnen und auf Fehler prüfen
Private Sub Form_Load()
   Dim i As Long

   If FileLen(AppPath) <= FileLength - 1 Then
      Call MsgBox("Es ist ein Fehler aufgetreten" & vbCrLf & "Dem Archiv sind keine Daten angehängt", vbCritical)
      IsOK = False
      Command1.Enabled = False
   Else
      Call sfx_Open
      IsOK = True
   End If
End Sub

'--------- Ende Formular "frmSFX" alias frmSFX.frm  ---------
'---------- Anfang Modul "mdlSFX" alias mdlSFX.bas ----------
Option Explicit

Global Const FileLength As Long = &H6001  ' Größe der eigenen Datei

Private ff              As Integer        ' Dateinummer

' Korrekter eigener Pfad
Public Property Get AppPath() As String
   AppPath = App.Path & IIf(Right(App.Path, 1) <> "\", "\", "") & App.EXEName & ".exe"
End Property

' Eigene Datei öffnen und den Dateizeiger zum Beginn des Anhangs schieben
Public Sub sfx_Open()
   ff = FreeFile
   
   Open AppPath For Binary Access Read Shared As #ff
      Seek #ff, FileLength
End Sub

' Anhang (hier als ByteArray) lesen
Public Function sfx_ReadAll() As Byte()
   Dim Contents() As Byte
   
   ReDim Contents(FileLen(AppPath) - FileLength) As Byte
   Get #ff, , Contents
    
   sfx_ReadAll = Contents
End Function

' Schließen
Public Sub sfx_Close()
   Close #ff
End Sub

'----------- Ende Modul "mdlSFX" alias mdlSFX.bas -----------
'---------------- Ende Projektdatei SFX.vbp  ----------------
'---------- Ende Projektgruppe SelfExtraction.vbg  ----------