Announcement

**Semen Matusovski** · 27 Apr 2000, 08:13 PM

Current "skeleton" of setup program.

Code:

   ' Skeleton of setup program, prepared by PB Sfx utility
   #Compile Exe
   #Dim All
   #Register None
   #Include "Win32Api.Inc"

   Global ErrMsg As String, TmpAsciiz As Asciiz * %MAX_PATH
   Global ExeDir As String, WinDir As String, SysDir As String
   Global AppDir As String, DstDir As String
   Global ExeInfo As String, Contents As String, lContents As Long
   Global TotalFilesSize As Double, ExtractedSize As Double
   Global hDlgMain As Long, hDlgProgress As Long

   %ID_Frame1    = 101
   %ID_InsideDir = 102
   %ID_SelectDir = 103
   %ID_Frame2    = 104
   %ID_DstDir    = 105
   %ID_Install   = 106
   %ID_Cancel    = 107
   %ID_Extract   = 108
   %ID_Progress  = 109

   Declare Sub CoTaskMemFree Lib "ole32.dll" Alias "CoTaskMemFree" (pv As Long)

   Type FILE_IN_CABINET_INFO
      NameInCabinet As Asciiz Ptr
      FileSize As Dword
      Win32Error As Dword
      DosDate As Word
      DosTime As Word
      DosAttribs As Word
      FullTargetName As Asciiz * %MAX_PATH
   End Type

   %SPFILENOTIFY_FILEINCABINET  = &H11
   %SPFILENOTIFY_FILEEXTRACTED  = &H13

   Declare Function SetupIterateCabinet Lib "SetupApi.Dll" Alias "SetupIterateCabinetA" _
      (CabinetFile As Asciiz, ByVal Reserved As Dword, _
      ByVal MsgHandler As Long, ByVal hContext As Long) As Long

   $Signature = "[CREATED BY PBSFX 1.01]"

   Sub Decrypt (Info As String)
      ' Decrypt Cabinet file
   End Sub

   Function UCaseSl(DirNm As String) As String
      If Left$(DirNm, 2) = "\\" Then ExitProcess -1
      CharUpperBuff ByVal StrPtr(DirNm), Len(DirNm)
      If Right$(DirNm, 1) <> "\" Then Function = DirNm + "\" Else Function = DirNm
   End Function

   Function MkDirEx (DirNm As String) As Long
      Static k1 As Long, k2 As Long
      k1 = 4
      Do
         If k1 > Len(DirNm) Then Exit Do
         k2 = Instr(k1, DirNm, "\")
         MkDir Left$(DirNm, k2 - 1): k1 = k2 + 1
      Loop
      If (GetAttr(DirNm) And 16) = 16 Then Function = %False Else Function = %True
   End Function

   CallBack Function PicProc
      Static hBrush() As Long, hDC() As Long, hBmp() As Long, Clr() As Long
      Static i As Long, Done As Long, LpPaint As PaintStruct, tRect As Rect
      Select Case CbMsg
         Case %WM_INITDIALOG
            ReDim hDC(0 To 2): ReDim hBrush(1 To 2): ReDim hBmp(1 To 2): ReDim Clr(1 To 2)
            hBrush(1) = CreateSolidBrush(Rgb(  0,   0, 255)): Clr(1) = %White
            hBrush(2) = CreateSolidBrush(Rgb(255, 255, 255)): Clr(2) = %Black
         Case %WM_DESTROY
            For i = 1 To 2: DeleteObject hBrush(i): Next
            InvalidateRect GetParent(CbHndl), ByVal 0, %True
            UpdateWindow GetParent(CbHndl)
         Case %WM_ERASEBKGND: Function = 1: Exit Function
         Case %WM_USER + 1
            Done = CbWparam
            InValidateRect CbHndl, ByVal 0, %True: UpdateWindow CbHndl
         Case %WM_PAINT
            GetClientRect CbHndl, tRect
            hDC(0) = BeginPaint(CbHndl, LpPaint)
            For i = 1 To 2
               hDC(i)  = CreateCompatibleDC(hDC(0))
               hBmp(i) = CreateCompatibleBitMap (hDC(0), tRect.nRight, tRect.nBottom)
               SelectObject hDc(i), hBmp(i)
               FillRect hDC(i), tRect, hBrush(i)
               SetBkMode hDC(i), %TRANSPARENT
               SetTextColor hDC(i), Clr(i)
               DrawText hDC(i), Trim$(Str$(Done)) + "%", -1, tRect, _
                  %DT_SINGLELINE Or %DT_CENTER Or %DT_VCENTER
            Next
            BitBlt hDC(2), 0, 0, tRect.nRight * Done * 0.01, tRect.nBottom, hDC(1), 0, 0, %SRCCOPY
            BitBlt hDC(0), 0, 0, tRect.nRight, tRect.nBottom, hDC(2), 0, 0, %SRCCOPY
            EndPaint CbHndl, LpPaint
            For i = 1 To 2: DeleteDC hDC(i): DeleteObject hBmp(i): Next
            Function = 0: Exit Function
      End Select
   End Function

   Sub SetClientSizeInUnits (hDlg As Long, WidthUnits As Long, HeightUnits As Long)
      Static lpRect As Rect, x As Long, y As Long
      GetWindowRect hDlg, lpRect
      x = (lpRect.nRight - lpRect.nLeft): y = (lpRect.nBottom - lpRect.nTop)
      GetClientRect hDlg, lpRect
      x = x - lpRect.nRight: y = y - lpRect.nBottom

      lpRect.nRight = WidthUnits: lpRect.nBottom = HeightUnits
      MapDialogRect hDlg, lpRect
      x = x + lpRect.nRight: y = y + lpRect.nBottom
      SetWindowPos hDlg, 0, (GetSystemMetrics(%SM_CXSCREEN) - x) / 2, _
         (GetSystemMetrics(%SM_CYSCREEN) - y) / 2, x, y, %SWP_NOZORDER
   End Sub

   Sub DeCompress
      Local i As Long, j As Long, k1 As Long, k2 As Long, CabInfo As String
      k1 = 1
      Do
         If k1 > lContents Then Exit Do
         k2 = Instr(k1, Contents, $CRLF): If k2 = 0 Then Exit Do
         i =  Instr(k1, Contents, "|"): j = Instr(i + 1, Contents, "|")
         DstDir = UCaseSl(Mid$(Contents, j + 1, k2 - j - 1))
         If Left$(DstDir, 8) = "$APPDIR\"  Then DstDir = AppDir + Mid$(DstDir,  9) Else _
         If Left$(DstDir, 9) = "$WINDOWS\" Then DstDir = WinDir + Mid$(DstDir, 10) Else _
         If Left$(DstDir, 8) = "$SYSTEM\"  Then DstDir = SysDir + Mid$(DstDir,  9)
         If MkDirEx(DstDir) Then Exit Do
         CabInfo = Mid$(ExeInfo, Val(Mid$(Contents, k1, i - k1)), _
            Val(Mid$(Contents, i + 1, j - i)))
         Open "Temp.Cab" For Output As #1 Len = 16384
         Decrypt CabInfo: Print #1, CabInfo: Close #1
         If Err <> 0 Then ErrMsg = "Can't write cabinet file": Exit Do
         SetupIterateCabinet "Temp.Cab", 0, CodePtr(CabinetCallback), 0
         k1 = k2 + 2
      Loop
   End Sub
   
   CallBack Function DlgProc
      Select Case CbMsg
         Case %WM_INITDIALOG
            SetClientSizeInUnits CbHndl, 250, 70
            Control Add Frame,   CbHndl, %ID_Frame1, " Inside (drive/directory) ", 5, 5, 240, 27
            Control Add TextBox, CbHndl, %ID_InsideDir, ExeDir, 10, 15, 210, 12
            Control Add Button,  CbHndl, %ID_SelectDir, "...", 225, 15, 15, 12
            Control Add Frame,   CbHndl, %ID_Frame2, " Application folder ", 5, 35, 120, 27
            Control Add TextBox, CbHndl, %ID_DstDir, "MyApp", 10, 45, 110, 12
            Control Add Button,  CbHndl, %ID_Install, "&Install", 140, 43, 50, 16, %BS_DEFAULT
            Control Add Button,  CbHndl, %ID_Cancel, "&Cancel", 195, 43, 50, 16

         Case %WM_COMMAND
            Select Case CbCtl
               Case %ID_SelectDir
                  Static pidl As Long, sBrowseInfo As BROWSEINFO, DisplayName As Asciiz * 256
                  sBrowseInfo.hWndOwner = CbHndl
                  sBrowseInfo.pIDLRoot = 0
                  sBrowseInfo.pszDisplayName = VarPtr(DisplayName)
                  ' sBrowseInfo.lpszTitle = StrPtr(Title)
                  sBrowseInfo.ulFlags = 1 ' (%BIF_RETURNONLYFSDIRS)
                  pidl = SHBrowseForFolder(sBrowseInfo)
                  If SHGetPathFromIDList(ByVal pidl, TmpAsciiz) Then _
                     Control Set Text CbHndl, %ID_InsideDir, TmpAsciiz
                  CoTaskMemFree ByVal pidl
               Case %ID_Install
                  Do
                     Control Get Text CbHndl, %ID_DstDir To DstDir
                     Control Get Text CbHndl, %ID_InsideDir To AppDir
                     AppDir = UCaseSl(Trim$(AppDir)): If Len(AppDir) < 3 Then Beep: Exit Do
                     If Trim$(DstDir) <> "" Then AppDir = AppDir + UCaseSl(DstDir)
                     If Len(AppDir) < 4 Then Beep: Exit Do
                     If MkDirEx(AppDir) Then Beep: Exit Do
                     Control Set Text CbHndl, %ID_Frame1, " Exctracting "
                     Control Kill CbHndl, %ID_InsideDir
                     Control Kill CbHndl, %ID_SelectDir
                     Control Add TextBox, CbHndl, %ID_Extract, ExeDir, 10, 17, 230, 12, %ES_READONLY

                     Control Set Text CbHndl, %ID_Frame2, " Progress "
                     Control Set Size CbHndl, %ID_Frame2, 180, 27
                     Control Kill CbHndl, %ID_DstDir
                     Control Kill CbHndl, %ID_Install
                     Dialog New CbHndl, "", 10, 45, 170, 12, %WS_CHILD Or %WS_VISIBLE Or _
                        %WS_BORDER To hDlgProgress
                     Dialog Show Modeless hDlgProgress Call PicProc
                     DeCompress: Dialog End CbHndl
                     Exit Do
                  Loop
               Case %ID_Cancel
                  Dialog End CbHndl
            End Select
      End Select
   End Function

   Function CabinetCallback (ByVal pMyInstallData As Long, _
      ByVal Notification As Dword, ByVal Param1 As Dword, ByVal Param2 As Dword) As Long
      Static szTarget As Asciiz * %MAX_PATH
      Static RemSize As Double
      Static pFile_In_Cabinet_Info As FILE_IN_CABINET_INFO Ptr
      Select Case Notification
          Case %SPFILENOTIFY_FILEINCABINET
            pFile_In_Cabinet_Info = Param1
            @pFile_In_Cabinet_Info.FullTargetName = DstDir + _
                @pFile_In_Cabinet_Info.@NameInCabinet
            RemSize = @pFile_In_Cabinet_Info.FileSize
            Control Set Text hDlgMain, %ID_Extract, @pFile_In_Cabinet_Info.FullTargetName
            UpdateWindow GetDlgItem(hDlgMain, %ID_Extract)
            Function = 1: Exit Function ' FILEOP_DOIT (Extract the file)
         Case %SPFILENOTIFY_FILEEXTRACTED
            ExtractedSize = ExtractedSize + RemSize
            Dialog Send hDlgProgress, %WM_USER + 1, CLng(ExtractedSize / TotalFilesSize * 100), 0
      End Select
      Function = 0
   End Function
   
   Function PbMain
      Local i As Long

      GetModuleFileName(GetModuleHandle(ByVal 0), TmpAsciiz, SizeOf(TmpAsciiz)
      ExeDir = UCaseSl(Left$(TmpAsciiz, Instr(-1, TmpAsciiz, "\") - 1))
      ChDrive Left$(ExeDir, 2): ChDir ExeDir

      Open TmpAsciiz For Binary Shared As #1: Get$ #1, Lof(1), ExeInfo: Close #1
      If Err <> 0 Then Exit Function ' Unexpected error
      If Right$(ExeInfo, Len($Signature)) <> $Signature Then _
         i = Shell ("PbSfx *", 1): Exit Function ' Started from IDE
      i = Len(ExeInfo) - Len($Signature) - 11
      TotalFilesSize = Cvd(ExeInfo, i): lContents = Cvl(ExeInfo, i + 8)
      Contents = Mid$(ExeInfo, i - lContents, lContents)
      GetWindowsDirectory TmpAsciiz, SizeOf(TmpAsciiz): WinDir = UCaseSl(ByCopy TmpAsciiz)
      GetSystemDirectory  TmpAsciiz, SizeOf(TmpAsciiz): SysDir = UCaseSl(ByCopy TmpAsciiz)
      Dialog New %HWND_DESKTOP, "Setup", , , 0, 0, %WS_SYSMENU Or %WS_MINIMIZEBOX To hDlgMain
      Dialog Show Modal hDlgMain Call DlgProc
      If ExtractedSize = TotalFilesSize Then MsgBox "Successful" Else MsgBox "Errors"
   End Function

[This message has been edited by Semen Matusovski (edited April 30, 2000).]

**Semen Matusovski** · 30 Apr 2000, 03:36 AM

Current release of PB Sfx utility

Code:

   ' PB Sfx  utility for creating self-extracting setup files
   '============================== Release 1.01 Apr, 30, 2000

   #Compile Exe
   #Dim All
   #Register None
   #Include "Win32Api.Inc"

   %maxCabs = 50
   $Signature = "[CREATED BY PBSFX 1.01]"
   $Release = "Release"

   Global WinDir As String, SysDir As String, ExeDir As String, RlsDir As String
   Global AppDir As String, AppName As String, TmpAsciiz As Asciiz * %MAX_PATH
   Global ErrMsg As String, Er As Long
   Global NmCabs() As String, nCabs As Long, TotalFilesSize As Double

   Sub Encrypt (Info As String)
      ' Crypt Cabinet file
   End Sub

   Function UCaseSl(DirNm As String) As String
      If Left$(DirNm, 2) = "\\" Then ExitProcess -1
      CharUpperBuff ByVal StrPtr(DirNm), Len(DirNm)
      If Right$(DirNm, 1) <> "\" Then Function = DirNm + "\" Else Function = DirNm
   End Function

   Function GetSizeOfFile(FileSpec As Asciiz) As Double
      Static FindData As WIN32_FIND_DATA, hFindFile As Long
      hFindFile = FindFirstFile(FileSpec, FindData)
      If hFindFile = %INVALID_HANDLE_VALUE Then Function = -1 Else _
      If (FindData.dwFileAttributes And %FILE_ATTRIBUTE_DIRECTORY) Then Function = -2 Else _
      Function = FindData.nFileSizeHigh * &H100000000 + FindData.nFileSizeLow: _
                 FindClose hFindFile
   End Function

   Sub AddSfxPart
      Local Info As String, i As Long, Contents As String

      Open RlsDir + AppName + ".Exe" For Output As #1 Len = 16384
      If Err <> 0 Then ErrMsg = "Can't create " + RlsDir + AppName + ".Exe": Exit Sub

      Open AppDir + AppName + ".Exe" For Binary Shared As #2
      Get$ #2, Lof(2), Info: Close #2
      If Err <> 0 Then ErrMsg = "Can't read " + AppDir + AppName + ".Exe": Exit Sub
      Print #1, Info;

      Open RlsDir + AppName + "0.Cab" For Input Shared As #2 Len = 16384: i = 0
      While Not Eof(2)
         Line Input #2, TmpAsciiz: TmpAsciiz = Trim$(TmpAsciiz)
         If TmpAsciiz <> "" Then
            If i = 0 Then
               i = 1: TotalFilesSize = Val(TmpAsciiz)
            Else
               Incr nCabs: If nCabs > %maxCabs Then Er = 1: Exit Do
               NmCabs(nCabs) = TmpAsciiz
            End If
         End If
      Wend
      Close #2
      If Er <> 0 Or Err <> 0 Or nCabs = 0 Then _
         ErrMsg = "Problems in " + RlsDir + AppName + "0.Cab": Exit Sub

      For i = 1 To nCabs
         Open RlsDir + AppName + Mid$(Str$(i), 2) + ".Cab" For Binary Shared As #2 Len = 16384
         Get$ #2, Lof(2), Info: Close #2
         If Err <> 0 Then ErrMsg = "Can't read " + _
           RlsDir + AppName + Mid$(Str$(i), 2) + ".Cab": Exit Sub
         EnCrypt Info
         Contents = Contents + Mid$(Str$(Lof(1) + 1), 2) + "|" + _
                               Mid$(Str$(Len(Info)), 2) + "|" + _
                               NmCabs(i) + $CRLF
         Print #1, Info;
      Next
      Print #1, Contents;
      Print #1, Mkd$(TotalFilesSize) + Mkl$(Len(Contents)) + $Signature;
      Close #1
      i = Shell(RlsDir + AppName + ".Exe", 1)
   End Sub

   Sub CreateCabinetFile
      %maxFiles = 500: ReDim NmFiles(1 To %maxFiles) As String
      Local nFiles As Long, EofSfx As Long, i As Long
      Dim FilesDir As String, FileSize As Double

      Open AppName + ".Sfx" For Input Shared As #1 Len = 16384
      If Err <> 0 Then ErrMsg = "Can't read " + AppName + ".Sfx": Exit Sub
      nCabs = 1
      Do
         EofSfx = Eof(1): If IsFalse(EofSfx) Then Line Input #1, TmpAsciiz
         If (EofSfx Or Left$(TmpAsciiz, 1) = "$") And nFiles > 0 Then
            If nCabs = 0 Then nCabs = 1: NmCabs(1) = "$APPDIR\"
            FilesDir = UCaseSl(NmCabs(nCabs))
            ' Undestands $AppDir $Windows $System
            If Left$(FilesDir, 8) = "$APPDIR\"  Then FilesDir = AppDir + Mid$(FilesDir,  9) Else _
            If Left$(FilesDir, 9) = "$WINDOWS\" Then FilesDir = WinDir + Mid$(FilesDir, 10) Else _
            If Left$(FilesDir, 8) = "$SYSTEM\"  Then FilesDir = SysDir + Mid$(FilesDir,  9)
            ChDrive Left$(FilesDir, 2): ChDir FilesDir
            If UCaseSl(CurDir$) <> FilesDir Then ErrMsg = "Can't find " + FilesDir: Exit Sub

            For i = 1 To nFiles
               FileSize = GetSizeOfFile(ByCopy NmFiles(i))
               If FileSize < 0 Then ErrMsg = "Can't find " + FilesDir + NmFiles(i): Exit Sub
               TotalFilesSize = TotalFilesSize + FileSize
            Next

            Open "PbSfx.Ddf" For Output As #2 Len = 16384
            If Err <> 0 Then ErrMsg = "Can't create PbSfx.Ddf in " + FilesDir: Exit Sub
            Print #2, ".OPTION Explicit"
            Print #2, ".Set Cabinet=Off"
            Print #2, ".Set Compress=Off"
            Print #2, ".Set MaxDiskSize=CDROM"
            Print #2, ".Set DiskDirectoryTemplate=" + Chr$(34) + AppDir  + $Release + Chr$(34)
            Print #2, ".Set CompressionType=MSZIP"
            Print #2, ".Set CompressionLevel=7"
            Print #2, ".Set CompressionMemory=21"
            Print #2, ".Set CabinetNameTemplate=" + Chr$(34) + AppName + _
               Mid$(Str$(nCabs), 2) + ".Cab" + Chr$(34)
            Print #2, ".Set Cabinet=On"
            Print #2, ".Set Compress=On"
            For i = 1 To nFiles
               Print #2, Chr$(34) + NmFiles(i) + Chr$(34)
            Next
            Close #2
            Shell "makecab /f PbSfx.Ddf"
            Kill "Setup.Inf": Kill "Setup.Rpt": Kill "PbSfx.Ddf"
            ChDrive Left$(AppDir, 2): ChDir AppDir
         End If
         If EofSfx Then Exit Do
         If Left$(TmpAsciiz, 1) = "*" Then ' Comments
         ElseIf Left$(TmpAsciiz, 1) = "$" Then
            If nFiles > 0 Then nFiles = 0: Incr nCabs
            If nCabs > %maxCabs Then Er = 1: Exit Do
            NmCabs(nCabs) = "$" + Trim$(Mid$(TmpAsciiz, 2)): _
               If Len(NmCabs(nCabs)) < 2 Then Er = 2: Exit Do
         Else
            Incr nFiles: If nFiles > %maxFiles Then Er = 3: Exit Do
            NmFiles(nFiles) = Trim$(TmpAsciiz): _
               If NmFiles(nFiles) = ""  Then Er = 4: Exit Do
         End If
      Loop
      Close #1
      If nFiles = 0 Then Decr nCabs
      If nCabs = 0 Then Er = 5
      If Er <> 0 Then ErrMsg = "Syntax error in " + AppName + ".Sfx": Exit Sub
      Open RlsDir + AppName + "0.Cab" For Output As #1 Len = 16384
      Print #1, Format$(TotalFilesSize, "#")
      For i = 1 To nCabs: Print #1, NmCabs(i): Next: Close #1
      If Err <> 0 Then ErrMsg = "Strange error"
   End Sub

   Function PbMain
      GetWindowsDirectory TmpAsciiz, SizeOf(TmpAsciiz): WinDir = UCaseSl(ByCopy TmpAsciiz)
      GetSystemDirectory  TmpAsciiz, SizeOf(TmpAsciiz): SysDir = UCaseSl(ByCopy TmpAsciiz)
      Do
         GetModuleFileName GetModuleHandle(ByVal 0), TmpAsciiz, SizeOf(TmpAsciiz)
         ExeDir = Left$(TmpAsciiz, Instr(-1, TmpAsciiz, "\"))
         If Dir$(UCaseSl(CurDir$) + "*.Sfx", 39) = "" Then _
            ChDrive Left$(ExeDir, 2): ChDir ExeDir ' From IDE

         AppDir = UCaseSl(CurDir$): RlsDir = UCaseSl(AppDir + $Release)
         AppName = Dir$("*.Sfx", 39)
         If Len(AppName) > 4 Then AppName = Left$(AppName, Len(AppName) - 4) Else _
            ErrMsg = ".Sfx is not found": Exit Do
         ReDim NmCabs(1 To %maxCabs) As String
         If Command$ = "" Then CreateCabinetFile Else AddSfxPart
         Exit Do
      Loop
      If ErrMsg <> "" Then MsgBox ErrMsg, , "PB Sfx"
   End Function

------------------

Announcement

Forum Guidelines

Self-Exe, based on MakeCab/Extract

Self-Exe, based on MakeCab/Extract

Comment

Comment