Create MS Cabinet *.cab [Windows of course]
Posted: Fri Dec 28, 2018 6:39 pm
Hi
The title say it all
Edit : Many bugs fixed
The title say it all
Code: Select all
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