[Module] ResourceModule.pbi

Hier könnt Ihr gute, von Euch geschriebene Codes posten. Sie müssen auf jeden Fall funktionieren und sollten möglichst effizient, elegant und beispielhaft oder einfach nur cool sein.
Benutzeravatar
Thorsten1867
Beiträge: 1359
Registriert: 04.02.2005 15:40
Computerausstattung: [Windows 10 x64] [PB V5.7x]
Wohnort: Kaufbeuren
Kontaktdaten:

[Module] ResourceModule.pbi

Beitrag von Thorsten1867 »

Ich habe nach einer simplen, betriebssystemübergreifenden Lösung für meine Ressouren (Images) gesucht.
Nachdem ich nicht wirklich etwas gefunden habe, habe ich selber etwas zusammengebastelt.
Vielleicht hat ja noch jemand Verwendung dafür.

Hier noch eine simple GUI, die gleichzeitig als Anwendungsbeispiel dienen kann:

Download: ResourceModule.zip

Code: Alles auswählen

;/ ===================================
;/ =  ResourceModule [PB 5.6x]       =
;/ ===================================
;/
;/ All OS
;/
;/ Module by Thorsten1867 (11/2017)
;/

#PackResource = #True

CompilerIf #PackResource
  
  DeclareModule PackResource
    
    Declare Open(File$, Name$)
    Declare Close(Name$)
    Declare Add(Name$, File$)
    Declare Create(Name$)
    
  EndDeclareModule

  Module PackResource
    
    EnableExplicit
    
    UseLZMAPacker()
    
    #Pack = 1
    #Json = 1
    
    Structure File_Structure
      File.s
      Size.i
    EndStructure
    
    Structure ResPack_Structure
      Open.i
      File.s
      Map Files.File_Structure()
    EndStructure
    
    Global NewMap ResPack.ResPack_Structure()
    
    Procedure Open(File$, Name$)
      
      If AddMapElement(ResPack(), Name$)
        ResPack()\Open = #True
        ResPack()\File = File$
        ProcedureReturn #True
      EndIf
      
      ProcedureReturn #False
    EndProcedure
    
    Procedure Create(Name$)
      Define Size.i, *Buffer
      Define File$, PackFile$
      
      If FindMapElement(ResPack(), Name$)
        
        PackFile$ = ResPack()\File
        
        If CreatePack(#Pack, PackFile$, #PB_PackerPlugin_Lzma, 9)
          
          ForEach ResPack()\Files()
            File$ = ResPack()\Files()\File
            AddPackFile(#Pack, File$, GetFilePart(File$))
          Next
          
          If CreateJSON(#Json)
            InsertJSONMap(JSONValue(#Json), ResPack()\Files())
            Size = ExportJSONSize(#JSON)
            *Buffer = AllocateMemory(Size)
            If *Buffer
              If ExportJSON(#JSON, *Buffer, Size)
                AddPackMemory(#Pack, *Buffer, Size, "Content.json")
              EndIf
              FreeMemory(*Buffer)
            EndIf
            FreeJSON(#Json)
          EndIf
  
          ClosePack(#Pack)
        EndIf
        
      EndIf
      
      ProcedureReturn #False
    EndProcedure
    
    Procedure Add(Name$, File$)
      Define FileName$, Size.i
      
      If FindMapElement(ResPack(), Name$)
        
        Size = FileSize(File$)
        If Size > 0
          
          FileName$ = GetFilePart(File$)
          ResPack()\Files(FileName$)\File = File$
          ResPack()\Files(FileName$)\Size = Size
          
          ProcedureReturn #True
        EndIf
        
      EndIf
      
      ProcedureReturn #False
    EndProcedure
    
    Procedure Close(Name$)
      If FindMapElement(ResPack(), Name$)
        DeleteMapElement(ResPack())
      EndIf
    EndProcedure
    
  EndModule

CompilerEndIf


DeclareModule Resource
  
  Declare Open(Pack.i, File$)
  Declare.i GetImage(Pack.i, Image.i, FileName$)
  Declare.i GetXML(Pack.i, XML.i, FileName$)
  Declare.i GetJSON(Pack.i, JSON.i, FileName$)
  Declare.i GetSound(Pack.i, Sound.i, FileName$)
  Declare.i GetFileSize(Pack.i, FileName$)
  Declare.i GetFileMemory(Pack.i, *Buffer, FileName$)
  Declare Close(Pack.i)
  
EndDeclareModule

Module Resource
  
  EnableExplicit

  UseLZMAPacker()
  
  #Pack = 1
  #JSON = 1
  
  Structure File_Structure
    Name.s
    Size.i
  EndStructure
  
  Structure Content_Structure
    PackFile.s
    Map Content.File_Structure()
  EndStructure
  
  Global NewMap ResEx.Content_Structure()
  
  Procedure Open(Pack.i, File$)
    Define.i Result, Size
    Define *Buffer
    
    Result = OpenPack(Pack, File$ , #PB_PackerPlugin_Lzma)
    If Result
      
      If Pack = #PB_Any : Pack = Result : EndIf
      
      ResEx(Str(Pack))\PackFile = File$
      
      If ExaminePack(Pack)
        While NextPackEntry(Pack)
          If PackEntryName(Pack) = "Content.json"
            Size    = PackEntrySize(Pack)
            *Buffer = AllocateMemory(Size)
            If *Buffer
              If UncompressPackMemory(Pack, *Buffer, Size)
                If CatchJSON(#JSON, *Buffer, Size) 
                  ExtractJSONMap(JSONValue(#JSON), ResEx()\Content())
                  FreeJSON(#JSON)
                EndIf
              EndIf
              FreeMemory(*Buffer)
            EndIf
            Break
          EndIf
        Wend
      EndIf
      
      ProcedureReturn Pack
    EndIf
    
    ProcedureReturn #False
  EndProcedure
  
  Procedure.i GetImage(Pack.i, Image.i, FileName$)
    Define.i Result.i, *Buffer

    If FindMapElement(ResEx(), Str(Pack))
      
      FileName$ = GetFilePart(FileName$)
      If FindMapElement(ResEx()\Content(), FileName$)
        
        *Buffer = AllocateMemory(ResEx()\Content()\Size)
        If *Buffer
          If UncompressPackMemory(Pack, *Buffer, ResEx()\Content()\Size, FileName$)
            Result = CatchImage(Image, *Buffer, ResEx()\Content()\Size)
            If Result
              If Image = #PB_Any : Image = Result :  EndIf
            Else
              Image = #False
            EndIf
          EndIf
          FreeMemory(*Buffer)
        EndIf
        
        ProcedureReturn Image
      EndIf
      
    EndIf
    
    ProcedureReturn #False
  EndProcedure
  
  Procedure.i GetSound(Pack.i, Sound.i, FileName$)
    Define.i Result.i, *Buffer

    If FindMapElement(ResEx(), Str(Pack))
      
      FileName$ = GetFilePart(FileName$)
      If FindMapElement(ResEx()\Content(), FileName$)
        
        *Buffer = AllocateMemory(ResEx()\Content()\Size)
        If *Buffer
          If UncompressPackMemory(Pack, *Buffer, ResEx()\Content()\Size, FileName$)
            Result =  CatchSound(Sound, *Buffer, ResEx()\Content()\Size)
            If Result
              If Sound = #PB_Any : Sound = Result :  EndIf
            Else
              Sound = #False
            EndIf
          EndIf
          FreeMemory(*Buffer)
        EndIf
        
        ProcedureReturn Sound
      EndIf
      
    EndIf
    
    ProcedureReturn #False
  EndProcedure
  
  Procedure.i GetXML(Pack.i, XML.i, FileName$)
    Define.i Result.i, *Buffer

    If FindMapElement(ResEx(), Str(Pack))
      FileName$ = GetFilePart(FileName$)
      If FindMapElement(ResEx()\Content(), FileName$)
        *Buffer = AllocateMemory(ResEx()\Content()\Size)
        If *Buffer
          If UncompressPackMemory(Pack, *Buffer, ResEx()\Content()\Size, FileName$)
            Result = CatchXML(XML, *Buffer, ResEx()\Content()\Size)
            If Result
              If XML = #PB_Any : XML = Result :  EndIf
            Else
              XML = #False
            EndIf
          EndIf
          FreeMemory(*Buffer)
        EndIf
      EndIf
      ProcedureReturn XML
    EndIf
    
    ProcedureReturn #False
  EndProcedure
  
  Procedure.i GetJSON(Pack.i, JSON.i, FileName$)
    Define Result.i, *Buffer

    If FindMapElement(ResEx(), Str(Pack))
      FileName$ = GetFilePart(FileName$)
      If FindMapElement(ResEx()\Content(), FileName$)
        *Buffer = AllocateMemory(ResEx()\Content()\Size)
        If *Buffer
          If UncompressPackMemory(Pack, *Buffer, ResEx()\Content()\Size, FileName$)
            Result = CatchJSON(JSON, *Buffer, ResEx()\Content()\Size)
            If Result
              If JSON = #PB_Any : JSON = Result :  EndIf
            Else
              JSON = #False
            EndIf
          EndIf
          FreeMemory(*Buffer)
        EndIf
      EndIf
      ProcedureReturn JSON
    EndIf
  EndProcedure
  
  Procedure.i GetFileSize(Pack.i, FileName$)
    If FindMapElement(ResEx(), Str(Pack))
      FileName$ = GetFilePart(FileName$)
      If FindMapElement(ResEx()\Content(), FileName$)
        ProcedureReturn ResEx()\Content()\Size
      EndIf
    EndIf
  EndProcedure
  
  Procedure.i GetFileMemory(Pack.i, *Buffer, FileName$)
    Define Result.i
    
    If FindMapElement(ResEx(), Str(Pack))
      FileName$ = GetFilePart(FileName$)
      If FindMapElement(ResEx()\Content(), FileName$)
        Result = UncompressPackMemory(Pack, *Buffer, ResEx()\Content()\Size, FileName$)
        ProcedureReturn Result
      EndIf
    EndIf
    ProcedureReturn #False
  EndProcedure
  
  Procedure Close(Pack.i)
    If FindMapElement(ResEx(), Str(Pack))
      DeleteMapElement(ResEx())
      ClosePack(Pack)
    EndIf
  EndProcedure
  
EndModule


CompilerIf #PB_Compiler_IsMainFile
  
  UsePNGImageDecoder()
  
  CompilerIf #PackResource
    If PackResource::Open("Test.res", "Test")
      
      PackResource::Add("Test", #PB_Compiler_Home + "examples\sources\Data\PureBasic.bmp")
      PackResource::Add("Test", #PB_Compiler_Home + "examples\sources\Data\CdPlayer.ico")
      PackResource::Add("Test", #PB_Compiler_Home + "examples\sources\Data\world.png")
      
      PackResource::Create("Test")
      
      PackResource::Close("Test")
    EndIf
  CompilerEndIf
  
  #Win = 0
  #Pack = 1
  #ImageGadget = 1
  #Image = 1
  
  If Resource::Open(#Pack, "Test.res")
    Resource::GetImage(#Pack, #Image, "PureBasic.bmp")
    Resource::Close(#Pack)
  EndIf
  
  If OpenWindow(#Win, 100, 100, 300, 200, "Resource - Image")
    
    If IsImage(#Image)
      ImageGadget(#ImageGadget, 10, 10, 100, 100, ImageID(#Image), #PB_Image_Border) 
    EndIf
    
    Repeat
      Event = WaitWindowEvent()
    Until Event = #PB_Event_CloseWindow  ; If the user has pressed on the close button
    
    CloseWindow(#Win)
  EndIf

  
CompilerEndIf
Download of PureBasic - Module
Download of PureBasic - Programmes

[Windows 11 x64] [PB V6]

Bild