Attribute VB_Name = "basResource"
Option Compare Binary
Option Explicit

Public Enum ResourceTypes
    RT_CURSOR = 1
    RT_BITMAP = 2
    RT_ICON = 3
    RT_MENU = 4
    RT_DIALOG = 5
    RT_STRING = 6
    RT_FONTDIR = 7
    RT_FONT = 8
    RT_ACCELERATOR = 9
    RT_RCDATA = 10
    RT_MESSAGETABLE = 11
    RT_GROUP_CURSOR = RT_CURSOR + 11
    RT_GROUP_ICON = RT_ICON + 11
    RT_VERSION = 16
    RT_DLGINCLUDE = 17
    RT_PLUGPLAY = 19
    RT_VXD = 20
    RT_ANICURSOR = 21
    RT_ANIICON = 22
    RT_HTML = 23
End Enum

' LoadLibraryEx dwFlags values
Public Enum LoadLibraryExFlags
    DONT_RESOLVE_DLL_REFERENCES = &H1&
    LOAD_LIBRARY_AS_DATAFILE = &H2&
    LOAD_WITH_ALTERED_SEARCH_PATH = &H8&
End Enum

' FormatMessage flags
Public Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Public Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Public Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Public Const FORMAT_MESSAGE_FROM_STRING = &H400
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Public Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF

' LoadImage lpszName flags for system defined OEM resources
' OBM = OEM bitmaps, OIC = OEM icons, and OCR = OEM cursors
Public Const OBM_BTNCORNERS = 32758
Public Const OBM_BTSIZE = 32761
Public Const OBM_CHECK = 32760
Public Const OBM_CHECKBOXES = 32759
Public Const OBM_CLOSE = 32754
Public Const OBM_COMBO = 32738
Public Const OBM_DNARROW = 32752
Public Const OBM_DNARROWD = 32742
Public Const OBM_DNARROWI = 32736
Public Const OBM_LFARROW = 32750
Public Const OBM_LFARROWD = 32740
Public Const OBM_LFARROWI = 32734
Public Const OBM_MNARROW = 32739
Public Const OBM_OLD_CLOSE = 32767
Public Const OBM_OLD_DNARROW = 32764
Public Const OBM_OLD_LFARROW = 32762
Public Const OBM_OLD_REDUCE = 32757
Public Const OBM_OLD_RESTORE = 32755
Public Const OBM_OLD_RGARROW = 32763
Public Const OBM_OLD_UPARROW = 32765
Public Const OBM_OLD_ZOOM = 32756
Public Const OBM_REDUCE = 32749
Public Const OBM_REDUCED = 32746
Public Const OBM_RESTORE = 32747
Public Const OBM_RESTORED = 32744
Public Const OBM_RGARROW = 32751
Public Const OBM_RGARROWD = 32741
Public Const OBM_RGARROWI = 32735
Public Const OBM_SIZE = 32766
Public Const OBM_UPARROW = 32753
Public Const OBM_UPARROWD = 32743
Public Const OBM_UPARROWI = 32737
Public Const OBM_ZOOM = 32748
Public Const OBM_ZOOMD = 32745
Public Const OCR_CROSS = 32515
Public Const OCR_IBEAM = 32513
Public Const OCR_ICOCUR = 32647
Public Const OCR_ICON = 32641
Public Const OCR_NO = 32648
Public Const OCR_NORMAL = 32512
Public Const OCR_SIZE = 32640
Public Const OCR_SIZEALL = 32646
Public Const OCR_SIZENESW = 32643
Public Const OCR_SIZENS = 32645
Public Const OCR_SIZENWSE = 32642
Public Const OCR_SIZEWE = 32644
Public Const OCR_UP = 32516
Public Const OCR_WAIT = 32514
Public Const OIC_BANG = 32515
Public Const OIC_HAND = 32513
Public Const OIC_NOTE = 32516
Public Const OIC_QUES = 32514
Public Const OIC_SAMPLE = 32512

Public Enum LoadImageTypes
    IMAGE_BITMAP = 0
    IMAGE_ICON = 1
    IMAGE_CURSOR = 2
    IMAGE_ENHMETAFILE = 3
End Enum

Public Enum LoadImageOptions
    LR_DEFAULTCOLOR = &H0
    LR_MONOCHROME = &H1
    LR_COLOR = &H2
    LR_COPYRETURNORG = &H4
    LR_COPYDELETEORG = &H8
    LR_LOADFROMFILE = &H10
    LR_LOADTRANSPARENT = &H20
    LR_DEFAULTSIZE = &H40
    LR_VGACOLOR = &H80
    LR_LOADMAP3DCOLORS = &H1000
    LR_CREATEDIBSECTION = &H2000
    LR_COPYFROMRESOURCE = &H4000
    LR_SHARED = &H8000
End Enum

Type PICTDESC
    cbSizeofStruct As Long
    PicType As Long
    hImage As Long              ' hBitmap, hIcon, or hMetafile
    xExt As Long                ' hPal for bitmap
    yExt As Long
End Type

' Functions for all platforms
Public Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
Public Declare Function FindResourceW Lib "kernel32" (ByVal hInstance As Long, ByVal lpName As Long, ByVal lpType As Long) As Long
Public Declare Function FindResourceExW Lib "kernel32" (ByVal hModule As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal wLanguage As Long) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Public Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Public Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Public Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pPictDesc As PICTDESC, riid As GUID, ByVal fOwn As Long, ppvObj As IPicture) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Public Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long

' Functions for Windows 95/Windows 98
Private Declare Function EnumResourceLanguagesA Lib "kernel32" (ByVal hModule As Long, ByVal lpType As Any, ByVal lpName As Any, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumResourceNamesA Lib "kernel32" (ByVal hModule As Long, ByVal lpType As Any, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumResourceTypesA Lib "kernel32" (ByVal hModule As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function LoadBitmapA Lib "user32" (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long
Private Declare Function LoadCursorA Lib "user32" (ByVal hInstance As Long, ByVal lpCursorName As String) As Long
Private Declare Function LoadIconA Lib "user32" (ByVal hInstance As Long, ByVal lpIconName As String) As Long
Private Declare Function LoadImageA Lib "user32" (ByVal hInst As Long, ByVal lpszName As String, ByVal uType As LoadImageTypes, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As LoadImageOptions) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function LoadLibraryExA Lib "kernel32" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As LoadLibraryExFlags) As Long
Private Declare Function LoadStringA Lib "user32" (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long

' Functions for Windows NT/Windows 2000
Private Declare Function EnumResourceLanguagesW Lib "kernel32" (ByVal hModule As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumResourceNamesW Lib "kernel32" (ByVal hModule As Long, ByVal lpType As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumResourceTypesW Lib "kernel32" (ByVal hModule As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function LoadBitmapW Lib "user32" (ByVal hInstance As Long, ByVal lpBitmapName As Long) As Long
Private Declare Function LoadCursorW Lib "user32" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadIconW Lib "user32" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
Private Declare Function LoadImageW Lib "user32" (ByVal hInst As Long, ByVal lpszName As Long, ByVal uType As LoadImageTypes, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As LoadImageOptions) As Long
Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lpLibFileName As Long) As Long
Private Declare Function LoadLibraryExW Lib "kernel32" (ByVal lpLibFileName As Long, ByVal hFile As Long, ByVal dwFlags As LoadLibraryExFlags) As Long
Private Declare Function LoadStringW Lib "user32" (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As Long, ByVal nBufferMax As Long) As Long

' OS-independent wrappers
Public Function EnumResourceLanguages(ByVal hModule As Long, ByVal lpType As String, ByVal lpName As String, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Dim fStringName As Boolean
    Dim fStringType As Boolean
    
    fStringName = (Val(lpName) > 65536 Or Val(lpName) = 0)
    fStringType = (Val(lpType) > 23 Or Val(lpType) = 0)
    
    If fStringName And fStringType Then
        If FOnWindowsNT() Then
            EnumResourceLanguages = EnumResourceLanguagesW(hModule, StrPtr(lpType), StrPtr(lpName), lpEnumFunc, lParam)
        Else
            EnumResourceLanguages = EnumResourceLanguagesA(hModule, lpType, lpName, lpEnumFunc, lParam)
        End If
    ElseIf fStringType Then
        If FOnWindowsNT() Then
            EnumResourceLanguages = EnumResourceLanguagesW(hModule, StrPtr(lpType), CLng(lpName), lpEnumFunc, lParam)
        Else
            EnumResourceLanguages = EnumResourceLanguagesA(hModule, lpType, CLng(lpName), lpEnumFunc, lParam)
        End If
    ElseIf fStringName Then
        If FOnWindowsNT() Then
            EnumResourceLanguages = EnumResourceLanguagesW(hModule, CLng(lpType), StrPtr(lpName), lpEnumFunc, lParam)
        Else
            EnumResourceLanguages = EnumResourceLanguagesA(hModule, CLng(lpType), lpName, lpEnumFunc, lParam)
        End If
    Else
        If FOnWindowsNT() Then
            EnumResourceLanguages = EnumResourceLanguagesW(hModule, CLng(lpType), CLng(lpName), lpEnumFunc, lParam)
        Else
            EnumResourceLanguages = EnumResourceLanguagesA(hModule, CLng(lpType), CLng(lpName), lpEnumFunc, lParam)
        End If
        
    End If
End Function

Public Function EnumResourceNames(ByVal hModule As Long, ByVal lpType As String, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Dim fStringType As Boolean
    
    fStringType = (Val(lpType) > 23 Or Val(lpType) = 0)
    
    If fStringType Then
        If FOnWindowsNT() Then
            EnumResourceNames = EnumResourceNamesW(hModule, StrPtr(lpType), lpEnumFunc, lParam)
        Else
            EnumResourceNames = EnumResourceNamesA(hModule, lpType, lpEnumFunc, lParam)
        End If
    Else
        If FOnWindowsNT() Then
            EnumResourceNames = EnumResourceNamesW(hModule, CLng(lpType), lpEnumFunc, lParam)
        Else
            EnumResourceNames = EnumResourceNamesA(hModule, CLng(lpType), lpEnumFunc, lParam)
        End If
    End If
End Function

Public Function EnumResourceTypes(ByVal hModule As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    If FOnWindowsNT() Then
        EnumResourceTypes = EnumResourceTypesW(hModule, lpEnumFunc, lParam)
    Else
        EnumResourceTypes = EnumResourceTypesA(hModule, lpEnumFunc, lParam)
    End If
End Function

Public Function LoadBitmap(ByVal hInstance As Long, ByVal lpBitmapName As String) As StdPicture
    Dim hBitmap As Long
    
    If FOnWindowsNT() Then
        hBitmap = LoadBitmapW(hInstance, StrPtr(lpBitmapName))
    Else
        hBitmap = LoadBitmapA(hInstance, lpBitmapName)
    End If
    
    Set LoadBitmap = IPictureFromImage(hBitmap, vbPicTypeBitmap)
End Function

Public Function LoadCursor(ByVal hInstance As Long, ByVal lpCursorName As String) As StdPicture
    Dim hCursor As Long
    
    If FOnWindowsNT() Then
        hCursor = LoadCursorW(hInstance, StrPtr(lpCursorName))
    Else
        hCursor = LoadCursorA(hInstance, lpCursorName)
    End If
    
    Set LoadCursor = IPictureFromImage(hCursor, vbPicTypeIcon)
End Function

Public Function LoadIcon(ByVal hInstance As Long, ByVal lpIconName As String) As StdPicture
    Dim hIcon As Long
    
    If FOnWindowsNT() Then
        hIcon = LoadIconW(hInstance, StrPtr(lpIconName))
    Else
        hIcon = LoadIconA(hInstance, lpIconName)
    End If
    Set LoadIcon = IPictureFromImage(hIcon, vbPicTypeIcon)
End Function

Public Function LoadImage(ByVal hInst As Long, ByVal lpszName As String, ByVal uType As LoadImageTypes, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As LoadImageOptions) As Long
    If FOnWindowsNT() Then
        LoadImage = LoadImageW(hInst, StrPtr(lpszName), uType, cxDesired, cyDesired, fuLoad)
    Else
        LoadImage = LoadImageA(hInst, lpszName, uType, cxDesired, cyDesired, fuLoad)
    End If
End Function

Public Function LoadString(ByVal hInstance As Long, ByVal wID As Long) As String
    Dim cch As Long
    Dim lpBuffer As String
    
    lpBuffer = String$(2048, vbNullChar)
    
    If FOnWindowsNT() Then
        cch = LoadStringW(hInstance, wID, StrPtr(lpBuffer), Len(lpBuffer))
    Else
        cch = LoadStringA(hInstance, wID, lpBuffer, LenB(StrConv(lpBuffer, vbFromUnicode)))
    End If
    
    If cch > 0 Then
        LoadString = Left$(lpBuffer, cch)
    Else
        Err.Raise Err.LastDllError
    End If
End Function

Public Function LoadLibraryC(ByVal stFileName As String, Optional fEnumFunction As Boolean = False) As Long
    If FOnWindowsNT() Then
        ' on NT/Win2K, the fastest call does no dll resolves and always loads the  file as a datafile
        LoadLibraryC = LoadLibraryExW(StrPtr(stFileName), 0&, DONT_RESOLVE_DLL_REFERENCES Or LOAD_LIBRARY_AS_DATAFILE)
    Else
        ' On Win9x, only the wnumeration functions can load the file as a datafile
        If fEnumFunction Then
            LoadLibraryC = LoadLibraryExA(stFileName, 0&, LOAD_LIBRARY_AS_DATAFILE)
        Else
            LoadLibraryC = LoadLibraryA(stFileName)
        End If
    End If
End Function

Public Function LoadResDataEx(stFileName As String, id As String, restype As String, lang As Long) As Variant
    Dim hModule As Long
    Dim hResource As Long
    Dim hData As Long
    Dim cbData As Long
    Dim rgbyt() As Byte
    Dim fStringName As Boolean
    Dim fStringType As Boolean
    
    If Len(stFileName) = 0 Then
        ' No filename specificed, assume resources in the current file
        LoadResDataEx = LoadResData(id, restype)
    Else
        hModule = LoadLibraryC(stFileName, True)
        If hModule <> 0 Then
            fStringName = (Val(id) > 65536 Or Val(id) = 0)
            fStringType = (Val(restype) > 23 Or Val(restype) = 0)
            If fStringName And fStringType Then
                hResource = FindResourceExW(hModule, StrPtr(restype), StrPtr(id), lang)
            ElseIf fStringName Then
                hResource = FindResourceExW(hModule, CLng(restype), StrPtr(id), lang)
            ElseIf fStringType Then
                hResource = FindResourceExW(hModule, StrPtr(restype), CLng(id), lang)
            Else
                hResource = FindResourceExW(hModule, CLng(restype), CLng(id), lang)
            End If
            If hResource <> 0 Then
                cbData = SizeofResource(hModule, hResource)
                If cbData > 0 Then
                    hData = LoadResource(hModule, hResource)
                    If hData <> 0 Then
                        ReDim rgbyt(0 To cbData - 1)
                        RtlMoveMemory ByVal VarPtr(rgbyt(0)), ByVal hData, cbData
                        LoadResDataEx = rgbyt
                    End If
                End If
            End If
            Call FreeLibrary(hModule)
        End If
    End If
End Function

Private Function IPictureFromImage(hImage As Long, ByVal PicType As PictureTypeConstants) As StdPicture
    Dim ip As IPicture
    Dim picdesc As PICTDESC
    Dim iidIDispatch As GUID
    
    
    picdesc.cbSizeofStruct = Len(picdesc)
    picdesc.PicType = PicType
    picdesc.hImage = hImage

    ' The IDispatch GUID: {00020400-0000-0000-C000-000000000046}
    iidIDispatch = GuidFromStGuid("{00020400-0000-0000-C000-000000046}")
    
    If OleCreatePictureIndirect(picdesc, iidIDispatch, True, ip) = 0 Then
        Set IPictureFromImage = ip
    End If
End Function