GFProgramResource/GFProgramResourcemod.bas

Attribute VB_Name = "GFProgramResourcemod"
Option Explicit
'(c)2001 by Louis. Use this module to dynamically unpack and delete files.
'
'NOTE: how to use the GFPR system:
'The target project should contain a sub called DefineGFPRSystem,
'where the GFPR system is initialized and all resources are registered.
'Pass the return value of GFPR_CreateResource() to any function that
'needs the path to the resource.
'Delete the resource instantly after usage to avoid tons of data trash in the
'case of a program crash.
'
'GFPRStruct ‑ saves general information
Private Type GFPRSystemStruct
    PacketCarrierFile As String
    OutputDir As String
End Type
Dim GFPRSystemStructVar As GFPRSystemStruct
'GFPRStruct ‑ saves resource information
Private Type GFPRStruct
    SystemResourceName As String
    SPackResourceName As String
    ResourceFileName As String 'directory and file name
End Type
Dim GFPRStructNumber As Integer
Dim GFPRStructArray() As GFPRStruct

'************************************INTERFACE SUBS*************************************

Public Sub GFPR_Initialize(ByVal PacketCarrierFile As String, ByVal OutputDir As String)
    'on error resume next
    If Not ((Dir$(PacketCarrierFile) = "") Or (Right$(PacketCarrierFile, 1) = "\") Or (PacketCarrierFile = "")) Then
        GFPRSystemStructVar.PacketCarrierFile = PacketCarrierFile
    Else
        MsgBox "internal error in GFPR_Initialize() (GFProgramResource): file '" + PacketCarrierFile + "' not found !", vbOKOnly + vbExclamation
    End If
    If Not (OutputDir = "") Then 'verify
        If Not (Right$(OutputDir, 1) = "\") Then OutputDir = OutputDir + "\"
        GFPRSystemStructVar.OutputDir = OutputDir
    Else
        MsgBox "internal error in GFPR_Initialize() (GFProgramResource): passed value invalid !", vbOKOnly + vbExclamation
    End If
End Sub

Public Sub GFPR_RegisterResource(ByVal SystemResourceName As String, ByVal SPackResourceName As String)
    'on error resume next 'call once
    'verify
    If Not (GetGFPRStructIndex(SystemResourceName) = 0) Then
        MsgBox "internal error in GFPR_RegisterResource(): SystemResourceName '" + SystemResourceName + "' already in use !", vbOKOnly + vbExclamation
        Exit Sub 'error
    End If
    'begin
    If Not (GFPRStructNumber = 32766) Then 'verify
        GFPRStructNumber = GFPRStructNumber + 1
    Else
        Exit Sub 'error
    End If
    ReDim Preserve GFPRStructArray(1 To GFPRStructNumber) As GFPRStruct
    GFPRStructArray(GFPRStructNumber).SystemResourceName = SystemResourceName
    GFPRStructArray(GFPRStructNumber).SPackResourceName = SPackResourceName
End Sub

Public Function GFPR_CreateResource(ByVal SystemResourceName As String, Optional ByVal ResourceFileName As String = "") As String
    'on error resume next 'may be called more than once; returns full path to resource file
    Dim StructIndex As Integer
    '
    'NOTE: the resource file will only be created if it is not existing yet.
    '
    'begin
    StructIndex = GetGFPRStructIndex(SystemResourceName)
    If Not (StructIndex = 0) Then
        If Not ((Dir$(GFPRStructArray(StructIndex).ResourceFileName) = "") Or (Right$(GFPRStructArray(StructIndex).ResourceFileName, 1) = "\") Or (GFPRStructArray(StructIndex).ResourceFileName = "")) Then
            GFPR_CreateResource = GFPRStructArray(StructIndex).ResourceFileName 'ok
        Else
            If ResourceFileName = "" Then
                GFPRStructArray(StructIndex).ResourceFileName = GenerateTempFileName(GFPRSystemStructVar.OutputDir)
            Else
                GFPRStructArray(StructIndex).ResourceFileName = GFPRSystemStructVar.OutputDir + ResourceFileName
            End If
            If GFPRStructArray(StructIndex).ResourceFileName = "" Then GoTo Error:
            If GFSPACK_UnpackFile(GFPRSystemStructVar.PacketCarrierFile, True, Nothing, GFPRStructArray(StructIndex).SPackResourceName, GFPRStructArray(StructIndex).ResourceFileName) = False Then GoTo Error:
            GFPR_CreateResource = GFPRStructArray(StructIndex).ResourceFileName 'ok
        End If
    Else
        MsgBox "internal error in GFPR_CreateResource(): passed value invalid !", vbOKOnly + vbExclamation
    End If
    Exit Function
Error:
    MsgBox "internal error in GFPR_CreateResource() !", vbOKOnly + vbExclamation
    GFPR_CreateResource = "" 'reset (error)
    Exit Function
End Function

Public Sub GFPR_DeleteResource(ByVal SystemResourceName As String)
    'on error resume next
    Dim StructIndex As Integer
    'begin
    StructIndex = GetGFPRStructIndex(SystemResourceName)
    If Not (StructIndex = 0) Then
        If Not ((Dir$(GFPRStructArray(StructIndex).ResourceFileName) = "") Or (Right$(GFPRStructArray(StructIndex).ResourceFileName, 1) = "\") Or (GFPRStructArray(StructIndex).ResourceFileName = "")) Then
            Kill GFPRStructArray(StructIndex).ResourceFileName
            GFPRStructArray(StructIndex).ResourceFileName = "" 'reset
        End If
    Else
        'do nothing (generally create no error message when an object is already deleted)
    End If
End Sub

'
'NOTE: use the next 2 functions to get one parameter passed to
'GFPR_RegisterResource() from the other one.
'

Public Function GFPR_SPackResourceNameToSystemResourceName(ByVal SPackResourceName As String) As String
    'on error resume next 'converts file name to resource name
    Dim StructLoop As Integer
    'preset
    For StructLoop = 1 To GFPRStructNumber
        If GFPRStructArray(StructLoop).SPackResourceName = SPackResourceName Then
            GFPR_SPackResourceNameToSystemResourceName = GFPRStructArray(StructLoop).SystemResourceName 'ok
            Exit Function
        End If
    Next StructLoop
    GFPR_SPackResourceNameToSystemResourceName = "" 'error
    Exit Function
End Function

Public Function GFPR_SystemResourceNameToSPackResourceName(ByVal SystemResourceName As String) As String
    'on error resume next
    Dim StructIndex As Integer
    'preset
    StructIndex = GetGFPRStructIndex(SystemResourceName)
    'begin
    If (StructIndex) Then
        GFPR_SystemResourceNameToSPackResourceName = GFPRStructArray(StructIndex).SPackResourceName 'ok
    Else
        GFPR_SystemResourceNameToSPackResourceName = "" 'error
    End If
End Function

'*********************************END OF INTERFACE SUBS*********************************
'*****************************************OTHER*****************************************

Private Function GetGFPRStructIndex(ByVal SystemResourceName As String)
    'on error resume next
    Dim StructLoop As Integer
    For StructLoop = 1 To GFPRStructNumber
        If GFPRStructArray(StructLoop).SystemResourceName = SystemResourceName Then
            GetGFPRStructIndex = StructLoop 'ok
            Exit Function
        End If
    Next StructLoop
    GetGFPRStructIndex = 0 'error
    Exit Function
End Function

'*************************************END OF OTHER**************************************
'***********************************GENERAL FUNCTIONS***********************************

Private Function GenerateTempFileName(ByVal TempFilePath As String) As String
    'On Error Resume Next 'returns name of a non‑existing file in TempFilePath, file name has following format: ########.tmp
    Dim GenerateTempFileTemp As Integer
    If (Not (Right$(TempFilePath, 1) = "\")) And (Not (TempFilePath = "")) Then
        TempFilePath = TempFilePath + "\"
    End If
    Do
        GenerateTempFileName = TempFilePath + Format$((Rnd(1) * 1E+08!), "00000000") + ".tmp"
        GenerateTempFileTemp = GenerateTempFileTemp + 1 'just to make sure
    Loop Until (Dir$(GenerateTempFileName) = "") Or (GenerateTempFileTemp = 32767)
End Function


[END OF FILE]