External Resources Demonstration Project (52K)
JPG Resource File Sample Project (43K)
1 Nov 1999
First Posted
vbAccelerator - Contents of code file: frmResourceEnum.frm
VERSION 5.00
Begin VB.Form frmResourceEnum
Caption = "Resource Enumeration"
ClientHeight = 5745
ClientLeft = 5595
ClientTop = 2160
ClientWidth = 6240
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmResourceEnum.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5745
ScaleWidth = 6240
Begin VB.CommandButton cmdSave
Height = 375
Left = 5820
Picture = "frmResourceEnum.frx":014A
Style = 1 'Graphical
TabIndex = 18
Top = 3360
Width = 375
End
Begin VB.ComboBox cboResources
Height = 315
Left = 660
Style = 2 'Dropdown List
TabIndex = 17
Top = 1080
Width = 5115
End
Begin VB.TextBox txtData
Height = 1995
Left = 660
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 15
Text = "frmResourceEnum.frx":0294
Top = 3360
Visible = 0 'False
Width = 5115
End
Begin VB.ListBox lstResources
Height = 1815
Left = 660
TabIndex = 14
Top = 1440
Width = 5115
End
Begin VB.CommandButton cmdPick
Height = 315
Left = 5820
Picture = "frmResourceEnum.frx":029C
Style = 1 'Graphical
TabIndex = 12
Top = 660
Width = 375
End
Begin VB.TextBox txtFile
Height = 315
Left = 660
TabIndex = 11
Top = 660
Width = 5115
End
Begin VB.Label lblItem
BorderStyle = 1 'Fixed Single
Height = 315
Left = 4560
TabIndex = 20
Top = 5400
Width = 1635
End
Begin VB.Label lblStatus
BorderStyle = 1 'Fixed Single
Height = 315
Left = 60
TabIndex = 19
Top = 5400
Width = 4455
End
Begin VB.Label lblInfo
Caption = "Please select a resource."
Height = 675
Left = 660
TabIndex = 16
Top = 3360
Width = 5115
End
Begin VB.Image imgPic
Height = 1995
Left = 660
Top = 3360
Visible = 0 'False
Width = 5115
End
Begin VB.Label lblRes
Caption = "Res:"
Height = 255
Left = 60
TabIndex = 13
Top = 1080
Width = 495
End
Begin VB.Label lblFile
Caption = "File:"
Height = 255
Left = 60
TabIndex = 10
Top = 720
Width = 495
End
Begin VB.Label lblGfxCaption
BackStyle = 0 'Transparent
Caption = "Resource Enum"
BeginProperty Font
Name = "Tahoma"
Size = 15.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00E0E0E0&
Height = 495
Left = 3660
TabIndex = 9
Top = 120
Width = 3195
End
Begin VB.Label lblGfxBlock
BackColor = &H000040C0&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 7
Left = 2340
TabIndex = 8
Top = 360
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H000080FF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 6
Left = 2100
TabIndex = 7
Top = 360
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H0080C0FF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 5
Left = 1860
TabIndex = 6
Top = 360
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H00C0E0FF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 4
Left = 1620
TabIndex = 5
Top = 360
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H00C0C000&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 3
Left = 2340
TabIndex = 4
Top = 120
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H00FFFF00&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 2
Left = 2100
TabIndex = 3
Top = 120
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H00FFFF80&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 1
Left = 1860
TabIndex = 2
Top = 120
Width = 195
End
Begin VB.Label lblGfxBlock
BackColor = &H00FFFFC0&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Index = 0
Left = 1620
TabIndex = 1
Top = 120
Width = 195
End
Begin VB.Image imgGraphic
Height = 375
Left = 105
Picture = "frmResourceEnum.frx":03E6
Top = 150
Width = 1500
End
Begin VB.Label lblGfxBack
BackColor = &H00000000&
BorderStyle = 1 'Fixed Single
Caption = "Label1"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 60
TabIndex = 0
Top = 60
Width = 6135
End
End
Attribute VB_Name = "frmResourceEnum"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_cLib As New cLibrary
Private Sub LoadResourceList(ByVal sFile As String)
Dim i As Long
Dim j As Long
Dim lType As Long
On Error GoTo ErrorHandler
' Load up the library as a datafile:
m_cLib.Filename = sFile
' If we get it:
If Not m_cLib.hModule = 0 Then
cboResources.Clear
lstResources.Clear
txtFile.Text = sFile
' Then enumerate through all the resources:
Dim cR As New cResources
cR.hModule = m_cLib.hModule
' First ask what types there are:
cR.GetResourceTypes
' For each type present...
For i = 1 To cR.ResourceTypeCount
If IsNumeric(cR.ResourceType(i)) Then
lType = cR.ResourceType(i)
cboResources.AddItem cR.ResourceTypeName(lType)
cboResources.ItemData(cboResources.NewIndex) = lType
Else
lType = -1
cboResources.AddItem cR.ResourceType(i)
End If
Next i
If cboResources.ListCount > 0 Then
cboResources.ListIndex = 0
End If
End If
' When cL goes out of scope, the library will be freed.
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbInformation
Exit Sub
Resume 0
End Sub
Private Sub cboResources_Click()
Dim i As Long
Dim j As Long
Dim cR As New cResources
If cboResources.ListIndex > -1 Then
cR.hModule = m_cLib.hModule
cR.GetResourceTypes
lstResources.Clear
' We ask for the individual resources underneath:
cR.GetResourceTypes
i = cboResources.ListIndex + 1
cR.GetResourceNames i
For j = 1 To cR.ResourceNameCount(i)
lstResources.AddItem cR.ResourceName(i, j)
Next j
If lstResources.ListCount > 0 Then
lstResources.ListIndex = 0
End If
End If
End Sub
Private Sub cmdPick_Click()
Dim sFile As String
If VBGetOpenFileName(sFile, , , , , , "Binary Files
(*.EXE;*.DLL;*.OCX)|*.EXE;*.DLL;*.OCX|Executables (*.EXE)|*.EXE|Libraries
(*.DLL)|*.DLL|ActiveX Controls (*.OCX)|*.OCX|All Files (*.*)|*.*", 1, ,
"Choose Binary to Load Resources From", "EXE", Me.hWnd) Then
LoadResourceList sFile
End If
End Sub
Private Sub cmdSave_Click()
Dim sFile As String
On Error GoTo ErrorHandler
sFile = lstResources.List(lstResources.ListIndex)
Select Case cboResources.ItemData(cboResources.ListIndex)
Case crGroupIcon
sFile = sFile & ".ICO"
Case crBitmap
sFile = sFile & ".BMP"
Case crGroupCursor
sFile = sFile & ".CUR"
Case crHTML
sFile = sFile & ".HTM"
Case crAniCursor, crAniIcon
sFile = sFile & ".ANI"
Case Else
Select Case True
Case cboResources.List(cboResources.ListIndex) = "AVI"
sFile = sFile & ".AVI"
Case cboResources.List(cboResources.ListIndex) = "ANI"
sFile = sFile & ".ANI"
End Select
End Select
If VBGetSaveFileName(sFile, , , , , , , , Me.hWnd) Then
If imgPic.Visible Then
SavePicture imgPic.Picture, sFile
Else
If cboResources.ItemData(cboResources.ListIndex) > 0 Then
SaveResource m_cLib.hModule,
lstResources.List(lstResources.ListIndex),
cboResources.ItemData(cboResources.ListIndex), sFile
Else
SaveResource m_cLib.hModule,
lstResources.List(lstResources.ListIndex),
cboResources.List(cboResources.ListIndex), sFile
End If
End If
End If
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbInformation
End Sub
Private Sub Form_Load()
LoadResourceList GetLocationFromAppPaths("WORDPAD.EXE")
End Sub
Private Function GetLocationFromAppPaths(ByVal sExeName As String) As String
Dim cR As New cRegistry
cR.ClassKey = HKEY_LOCAL_MACHINE
cR.SectionKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" &
sExeName
cR.ValueType = REG_SZ
GetLocationFromAppPaths = cR.Value
End Function
Private Sub lstResources_Click()
Dim eType As CRStandardResourceTypeConstants
Dim sId As String
On Error GoTo ErrorHandler
If lstResources.ListIndex > -1 Then
lblItem.Caption = lstResources.ListIndex + 1 & " of " &
lstResources.ListCount
eType = cboResources.ItemData(cboResources.ListIndex)
sId = lstResources.List(lstResources.ListIndex)
Select Case eType
Case crBitmap
Set imgPic.Picture = PictureFromResource(m_cLib.hModule, sId, crBitmap)
imgPic.Visible = True
lblInfo.Visible = False
txtData.Visible = False
Case crGroupIcon
Set imgPic.Picture = PictureFromResource(m_cLib.hModule, sId,
crGroupIcon)
imgPic.Visible = True
lblInfo.Visible = False
txtData.Visible = False
Case crGroupCursor
Set imgPic.Picture = PictureFromResource(m_cLib.hModule, sId,
crGroupCursor)
imgPic.Visible = True
lblInfo.Visible = False
txtData.Visible = False
Case Else
imgPic.Visible = False
txtData.Visible = False
lblInfo.Visible = True
lblInfo.Caption = "This type of resource cannot be displayed by the
application, but it can be extracted and saved."
End Select
End If
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbInformation
imgPic.Visible = False
txtData.Visible = False
Exit Sub
End Sub
