PureBasic Forum
http://forums.purebasic.com/english/

Create MS Cabinet *.cab [Windows of course]
http://forums.purebasic.com/english/viewtopic.php?f=12&t=72005
Page 1 of 1

Author:  RASHAD [ Fri Dec 28, 2018 6:39 pm ]
Post subject:  Create MS Cabinet *.cab [Windows of course]

Hi
The title say it all
Code:
Global Dim Filter.s(5)
Global Recursive,Path.s,dPath.s,comname.s,ddffile.s,Runcab, bi.BROWSEINFO,compratio.s
bi\lpszTitle = @"Choose Path"
ddffile = GetTemporaryDirectory()+"rashad.ddf"
compratio.s = "21"

Procedure ListFilesRecursive(Dir.s, List Files.s())
  NewList Directories.s()
  PathAddBackslash_(Dir)
  D = ExamineDirectory(#PB_Any, Dir, "")
  While NextDirectoryEntry(D)
    Select DirectoryEntryType(D)
      Case #PB_DirectoryEntry_File
        AddElement(Files())
        Files() =  Dir + DirectoryEntryName(D)
      Case #PB_DirectoryEntry_Directory
        Select DirectoryEntryName(D)
          Case ".", ".."
            Continue           
          Default
            If Recursive = 1
              AddElement(Directories())
              Directories() = Dir + DirectoryEntryName(D)
            EndIf
        EndSelect
    EndSelect
  Wend
  FinishDirectory(D)
  ForEach Directories()
    ListFilesRecursive(Directories(), Files())
  Next
  FreeList(Directories.s())
EndProcedure

Procedure Listfiles()
  ClearGadgetItems(16)
  Recursive = GetGadgetState(7)
  If FileSize(Path) <> -1
    NewList F.s() 
    PathAddBackslash_(Path)
    ListFilesRecursive(Path, F())
    Pos = Len(Path)+1
    ForEach F()
      Text.s = Mid(F(),pos)
      If GetGadgetText(5) = ""
        AddGadgetItem(16,-1,Text+Chr(10)+Str(FileSize(f())))
      Else
        Ftext.s = GetExtensionPart(F())
        For k = 1 To 5
          If ftext.s = Filter(k) And Filter(k) <> ""
            AddGadgetItem(16,-1,Text+Chr(10)+Str(FileSize(f())))
          EndIf
        Next
      EndIf
    Next
  Else
    MessageRequester("Error","Invalid source",#MB_OK|#MB_ICONERROR)
  EndIf
  FreeList(F())
EndProcedure   

Procedure Clear()
  ClearGadgetItems(16)
  SetGadgetText(2,"")  : Path  = ""
  SetGadgetText(41,"") : dPath = ""
  comname = ""
EndProcedure

Procedure.s Browse()
  *MemoryID = AllocateMemory(#MAX_PATH)
  bi\ulFlags = #BIF_NEWDIALOGSTYLE | #BIF_NONEWFOLDERBUTTON |#BIF_EDITBOX
  result.l = SHBrowseForFolder_(@bi)
  SHGetPathFromIDList_(result, *MemoryID)
  CoTaskMemFree_(result)
  Path = PeekS(*MemoryID) 
  FreeMemory(*MemoryID)
  If (Path)
    SetGadgetText(2, Path)
  EndIf
  ProcedureReturn Path
EndProcedure

Procedure.s Browse2()
  *MemoryID = AllocateMemory(#MAX_PATH) 
  bi\ulFlags = #BIF_NEWDIALOGSTYLE | #BIF_NONEWFOLDERBUTTON |#BIF_EDITBOX
  result.l = SHBrowseForFolder_(@bi)
  SHGetPathFromIDList_(result, *MemoryID)
  CoTaskMemFree_(result)
  dPath = PeekS(*MemoryID)
  FreeMemory(*MemoryID)
  If (dPath)
    SetGadgetText(41, dPath)
  EndIf
  ProcedureReturn (dPath)
EndProcedure

Procedure Run(par)
Repeat
  If Runcab = 1   
    HideGadget(18,0)
    PathAddBackslash_(Path)
    comname = StringField(Path, CountString(Path, "\"), "\")
    If dPath = ""
      dPath = GetHomeDirectory()
    EndIf
    OpenFile(0,ddffile, #PB_Ascii)
    WriteStringN(0,".New Cabinet")
    WriteStringN(0,".Set RptFileName="+GetTemporaryDirectory()+"cabtemp.rpt")
    WriteStringN(0,".Set InfFileName="+GetTemporaryDirectory()+"cabtemp.inf")
    WriteStringN(0,".Set FailOnMissingSource=On")
    WriteStringN(0,".Set MaxErrors=1")
    WriteStringN(0,".Set UniqueFiles=Off")
    WriteStringN(0,".Set Cabinet=Off")
    WriteStringN(0,".Set Compress=Off")
    WriteStringN(0,".Set CompressionType="+GetGadgetText(20))
    WriteStringN(0,".Set CompressionMemory="+compratio)
    WriteStringN(0,".Set MaxDiskSize=2147483136")
    WriteStringN(0,".Set DestinationDir="+Chr(34)+comname+Chr(34))
    WriteStringN(0,".Set DiskDirectory1="+Chr(34)+dPath+Chr(34))
    WriteStringN(0,".Set DiskDirectoryTemplate=.")
    WriteStringN(0,".Set CabinetNameTemplate="+comname+".cab")
    WriteStringN(0,".Set Cabinet=On")
    WriteStringN(0,".Set Compress=On")
    WriteStringN(0,".Set SourceDir="+Chr(34)+Path+Chr(34))         
   
    For item = 0 To CountGadgetItems(16)-1
      text$ = Chr(34)+GetGadgetItemText(16,item)+Chr(34)
      WriteStringN(0,text$+" "+text$)
    Next
   
  CloseFile(0)
  SetCurrentDirectory(Path)
  RunProgram("Makecab"," /F "+ddffile,"",#PB_Program_Hide | #PB_Program_Wait)
  DeleteFile(ddffile,#PB_FileSystem_Force)
  DeleteFile(GetTemporaryDirectory()+"cabtemp.inf", #PB_FileSystem_Force)
  DeleteFile(GetTemporaryDirectory()+"cabtemp.rpt", #PB_FileSystem_Force)
  Runcab = 0
  EndIf
  If IsGadget(18)
    HideGadget(18,1)
  EndIf 
ForEver
EndProcedure

Procedure WindowProc(hWnd,uMsg,wParam,lParam)
  Result = #PB_ProcessPureBasicEvents
  Select uMsg           
    Case #WM_NCACTIVATE
            Result = 1
  EndSelect
  ProcedureReturn Result
EndProcedure

Import "Uxtheme.lib"
  SetWindowTheme(Window.l, Body.p-unicode, Title.p-unicode)                                                 
EndImport

LoadFont(0,"Tahoma",16)
LoadFont(1,"Arial",12)

OpenWindow(0, 0, 0, 620, 360, "Create MS Cabinet", #PB_Window_ScreenCentered|#PB_Window_MinimizeGadget)
SetWindowCallback(@WindowProc())

FrameGadget(0, 10, 10, 600, 80, "  Select Folder / Files  ")
SetGadgetFont(0,FontID(1))
  TextGadget(1, 10, 33, 80, 20, "Source Dir:", #PB_Text_Center)
  StringGadget(2, 90, 30, 190, 20, "")
  ButtonGadget(3, 280, 30, 20, 20, "...")
  TextGadget(4, 302, 58, 80, 20, "Filter Files :", #PB_Text_Center)
  StringGadget(5, 390, 55, 190, 20, "")
  ButtonGadget(6, 580, 55, 20, 20, "?")
  CheckBoxGadget(7, 90, 55, 105, 20, "Recursive search")
  SetGadgetState(7,1)
  CheckBoxGadget(8, 195, 55, 110, 20, "Relative filenames")
  SetGadgetState(8,1)
  HideGadget(8,1)
   
  ButtonGadget(13,20, 315, 80, 25 , "List Files", #PB_Button_Default) 
 
  TextGadget(18,250,75,120,40,"Please Wait",#SS_CENTER | #SS_CENTERIMAGE)
  SetGadgetFont(18,FontID(0))
  HideGadget(18,1)
  SetGadgetColor(18,#PB_Gadget_FrontColor,$0000FF)     
  TextGadget(40, 310, 33, 80, 20, "Destination Dir:", #PB_Text_Center)
  StringGadget(41, 390, 30, 190, 20, "")
 
  CompilerIf #PB_Compiler_Unicode
    Text$ = "Type to Search"
  CompilerElse
    Text$ = Space(256)
    PokeS(@Text$,"Type to Search",-1,#PB_Unicode)
  CompilerEndIf
  SendMessage_(GadgetID(41), #EM_SETCUEBANNER, 0, GetHomeDirectory())
  ButtonGadget(42, 580, 30, 20, 20, "...")

FrameGadget(15, 10, 95, 600, 213, "  List && Create Cabinet  ")
SetGadgetFont(15,FontID(1))
  ListIconGadget(16, 22, 120, 575, 175, "File", 450,#PB_ListIcon_FullRowSelect |#PB_ListIcon_GridLines)
  Header = SendMessage_(GadgetID(16), #LVM_GETHEADER, 0, 0)
  SetWindowTheme(Header,"","WINDOW")
  SetGadgetFont(16,FontID(1))
  AddGadgetColumn(16, 1, "Size", 120)
  ButtonGadget(60,105, 315, 80, 25 , "Remove Item")
  ButtonGadget(65,190, 315, 80, 25 , "Undo..")
  ButtonGadget(70,275, 315, 80, 25 , "New Cabinet")
  ComboBoxGadget(20,402,316,55,22)
    AddGadgetItem(20, 0, "LZX")
    AddGadgetItem(20, 1, "MSZIP")
    SetGadgetState(20,0)
  SpinGadget(21,462,316,40,22,1,7,#PB_Spin_Numeric)
  SetGadgetState(21,7)   
  ButtonGadget(30, 505, 315, 95, 25, "  Build Cabinet")
  SendMessage_(GadgetID(30), #BCM_SETSHIELD, 0, #True) 

AddKeyboardShortcut(0, #PB_Shortcut_Return, 10)
SetActiveGadget(2)
Thread = CreateThread(@RUN(),30)

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_CloseWindow
      Quit = 1
     
    Case #PB_Event_Gadget
      Select EventGadget()
        Case 2 : Path.s = GetGadgetText(2)
       
        Case 3 : Browse()
       
        Case 5 : For k = 1 To 5
                  Filter(k) = StringField(GetGadgetText(5), k, ";")
                 Next
                 
        Case 6 : MessageRequester("Extensions", "Enter up to 5 file types separated by semicolon ; ", #MB_OK|#MB_ICONINFORMATION)
                 
        Case 7 : Recursive = GetGadgetState(7)       
       
        Case 13 : Path = GetGadgetText(2)
                  If Path = ""
                    MessageRequester("Error","No Items Selected",#MB_OK|#MB_ICONERROR)
                  Else
                    Listfiles()
                  EndIf
                 
        Case 20 : If GetGadgetState(20) = 0
                    DisableGadget(21,0)
                  Else
                    DisableGadget(21,1)
                  EndIf
                 
        Case 21 : compratio.s = Str(GetGadgetState(21) + 14 )     

        Case 30 : If CountGadgetItems(16) > 0
                    Runcab = 1
                  Else
                    MessageRequester("Error","No Items Selected",#MB_OK|#MB_ICONERROR)
                  EndIf
                 
        Case 42 : Browse2()
       
        Case 60 : If GetGadgetState(16) >= 0
                     RemoveGadgetItem(16, GetGadgetState(16))
                  Else
                    MessageRequester("Error","No Items Selected",#MB_OK|#MB_ICONERROR)
                  EndIf
                 
        Case 65 : Listfiles()
                 
        Case 70 : Clear()
      EndSelect
     
    Case #PB_Event_Menu
      Select EventMenu()
        Case 10 : Path = GetGadgetText(2)
                  If Path = ""
                    MessageRequester("Error","No Items Selected",#MB_OK|#MB_ICONERROR)
                  Else
                    Listfiles()
                  EndIf
      EndSelect
  EndSelect
Until Quit = 1


Edit : Many bugs fixed

Author:  Kwai chang caine [ Thu Jan 03, 2019 12:18 pm ]
Post subject:  Re: Create MS Cabinet *.cab [Windows of course]

I never use CABINET files since now, but that can be usefull a day :wink:
Thanks for sharing 8)

Author:  RSBasic [ Thu Jan 03, 2019 12:24 pm ]
Post subject:  Re: Create MS Cabinet *.cab [Windows of course]

Thanks for sharing :)

Page 1 of 1 All times are UTC + 1 hour
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
http://www.phpbb.com/