It is currently Fri Dec 06, 2019 9:02 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 3 posts ] 
Author Message
 Post subject: Create MS Cabinet *.cab [Windows of course]
PostPosted: Fri Dec 28, 2018 6:39 pm 
Offline
PureBasic Expert
PureBasic Expert

Joined: Sun Apr 12, 2009 6:27 am
Posts: 3469
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

_________________
Egypt my love


Top
 Profile  
Reply with quote  
 Post subject: Re: Create MS Cabinet *.cab [Windows of course]
PostPosted: Thu Jan 03, 2019 12:18 pm 
Offline
Addict
Addict
User avatar

Joined: Sun Nov 05, 2006 11:42 pm
Posts: 4542
Location: Lyon - France
I never use CABINET files since now, but that can be usefull a day :wink:
Thanks for sharing 8)

_________________
ImageThe happiness is a road...
Not a destination


Top
 Profile  
Reply with quote  
 Post subject: Re: Create MS Cabinet *.cab [Windows of course]
PostPosted: Thu Jan 03, 2019 12:24 pm 
Offline
Moderator
Moderator
User avatar

Joined: Thu Dec 31, 2009 11:05 pm
Posts: 1107
Location: Berlin (Germany)
Thanks for sharing :)

_________________
ImageImageImageImage Image


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 3 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 7 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye