vbAccelerator - Contents of code file: frmBitmapEx.frm

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmBitmapEx 
   Caption         =   "Resource Bitmap Extraction Utility"
   ClientHeight    =   6030
   ClientLeft      =   2130
   ClientTop       =   4020
   ClientWidth     =   6585
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmBitmapEx.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6030
   ScaleWidth      =   6585
   Begin ComctlLib.Toolbar tbrMain 
      Align           =   1  'Align Top
      Height          =   420
      Left            =   0
      TabIndex        =   2
      Top             =   0
      Width           =   6585
      _ExtentX        =   11615
      _ExtentY        =   741
      ButtonWidth     =   635
      ButtonHeight    =   582
      AllowCustomize  =   0   'False
      Wrappable       =   0   'False
      Appearance      =   1
      ImageList       =   "ilsIcons"
      _Version        =   327682
      BeginProperty Buttons {0713E452-850A-101B-AFC0-4210102A8DA7} 
         NumButtons      =   2
         BeginProperty Button1 {0713F354-850A-101B-AFC0-4210102A8DA7} 
            Key             =   "OPEN"
            Object.ToolTipText     =   "Opens a file"
            Object.Tag             =   ""
            ImageIndex      =   1
         EndProperty
         BeginProperty Button2 {0713F354-850A-101B-AFC0-4210102A8DA7} 
            Key             =   "SAVE"
            Object.ToolTipText     =   "Save selected resources"
            Object.Tag             =   ""
            ImageIndex      =   2
         EndProperty
      EndProperty
   End
   Begin ComctlLib.StatusBar sbrMain 
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   3
      Top             =   5655
      Width           =   6585
      _ExtentX        =   11615
      _ExtentY        =   661
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   1
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   1
            Object.Width           =   11086
            TextSave        =   ""
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.PictureBox picSplit 
      Align           =   1  'Align Top
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   5235
      Left            =   0
      ScaleHeight     =   5235
      ScaleWidth      =   6585
      TabIndex        =   0
      Top             =   420
      Width           =   6585
      Begin VB.PictureBox picBitmapArea 
         Height          =   5115
         Left            =   3660
         ScaleHeight     =   5055
         ScaleWidth      =   2835
         TabIndex        =   4
         Top             =   0
         Width           =   2895
         Begin VB.Frame fraBitmapInfo 
            Caption         =   "Bitmap Information"
            Height          =   1095
            Left            =   60
            TabIndex        =   6
            Top             =   0
            Width           =   2775
            Begin VB.Label lblBitmapInfo 
               Height          =   735
               Left            =   120
               TabIndex        =   7
               Top             =   240
               Width           =   2475
            End
         End
         Begin VB.PictureBox picBitmap 
            AutoRedraw      =   -1  'True
            BorderStyle     =   0  'None
            BeginProperty Font 
               Name            =   "MS Sans Serif"
               Size            =   8.25
               Charset         =   0
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   4035
            Left            =   0
            ScaleHeight     =   4035
            ScaleWidth      =   2835
            TabIndex        =   5
            Top             =   1140
            Width           =   2835
         End
      End
      Begin ComctlLib.TreeView tvwBitmaps 
         Height          =   5115
         Left            =   0
         TabIndex        =   1
         Top             =   0
         Width           =   3555
         _ExtentX        =   6271
         _ExtentY        =   9022
         _Version        =   327682
         HideSelection   =   0   'False
         Indentation     =   441
         LabelEdit       =   1
         LineStyle       =   1
         Style           =   6
         Appearance      =   1
      End
   End
   Begin ComctlLib.ImageList ilsIcons 
      Left            =   2220
      Top             =   5580
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} 
         NumListImages   =   2
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmBitmapEx.frx":1272
            Key             =   "OPEN"
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmBitmapEx.frx":144C
            Key             =   "SAVE"
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnuFileTOP 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "&Open..."
         Index           =   0
         Shortcut        =   ^O
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save..."
         Index           =   1
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save All..."
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuFile 
         Caption         =   "E&xit"
         Index           =   4
      End
   End
   Begin VB.Menu mnuOptionsTOP 
      Caption         =   "&Options"
      Begin VB.Menu mnuOptions 
         Caption         =   "Always Save Alpha &Channel"
         Index           =   0
      End
      Begin VB.Menu mnuOptions 
         Caption         =   "&Premultiply Alpha"
         Index           =   1
      End
   End
End
Attribute VB_Name = "frmBitmapEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cSplit As New cSplitter
Private m_cRes As New cResources
Private m_cLib As New cLibrary
Private m_cDib As New cAlphaDibSection

Private m_bPreMultiplyAlpha As Boolean
Private m_bAlwaysSaveAlphaChannel As Boolean

Private Sub pSelectNode()
   picBitmap.Cls
   lblBitmapInfo.Caption = ""
   
   If Not tvwBitmaps.SelectedItem Is Nothing Then
      Dim nodX As Node
      Set nodX = tvwBitmaps.SelectedItem
      If (nodX.Key = "TOP") Then
      Else
         Dim lIndex As Long
         Dim bColorDepth As Byte
         lIndex = Mid(nodX.Key, 2)
         Set m_cDib = DIBSectionFromResource(m_cLib.hModule, nodX.Text, True,
          bColorDepth)
         m_cDib.AlphaPaintPicture picBitmap.hdc, 2, 2
         lblBitmapInfo.Caption = "Width = " & m_cDib.Width & vbCrLf & "Height =
          " & m_cDib.Height & vbCrLf & "Colour Depth = " & bColorDepth & "
          bits/pixel"
      End If
   End If
   picBitmap.Refresh
End Sub

Private Sub pOpen()
   Dim sFile As String
   
   If (VBGetOpenFileName(sFile, _
      Filter:="Library Files (*.EXE;*.DLL)|*.EXE;*.DLL|Executables
       (*.EXE)|*.EXE|Libraries (*.DLL)|*.DLL|All Files (*.*)|*.*", _
      Owner:=Me.hwnd)) Then
      
      tvwBitmaps.Nodes.Clear
      picBitmap.Cls
      picBitmap.Refresh
      lblBitmapInfo.Caption = ""
      Set m_cDib = Nothing
      
      Dim nodTop As Node
      Set nodTop = tvwBitmaps.Nodes.Add(, , "TOP", sFile)
      
      On Error GoTo ErrorHandler
      m_cLib.Filename = sFile
      m_cRes.hModule = m_cLib.hModule
      m_cRes.GetResourceTypes
      If (m_cRes.ResourceTypeCount > 0) Then
         
         Dim i As Long
         Dim j As Long
         
         i = m_cRes.IndexOfResourceType(crBitmap)
         If (i > 0) Then
            m_cRes.GetResourceNames i
            For j = 1 To m_cRes.ResourceNameCount(i)
               tvwBitmaps.Nodes.Add nodTop, tvwChild, "C" & j,
                m_cRes.ResourceName(i, j)
            Next j
         End If
                        
      End If
      
      nodTop.Expanded = True
      If (nodTop.Children > 0) Then
         nodTop.Child.Selected = True
      End If
      
      pSelectNode
            
      sbrMain.Panels(1).Text = "Opened " & sFile & ". " & _
         IIf(tvwBitmaps.Nodes.Count > 1, _
            tvwBitmaps.Nodes.Count - 1 & " bitmaps in file.", _
            "No bitmaps in file.")

   End If
   Exit Sub
   
ErrorHandler:
   MsgBox "An error occurred trying to access this resource: " &
    Err.Description, vbInformation
   pSelectNode
   Exit Sub

End Sub

Private Sub pSave()
   If Not (tvwBitmaps.SelectedItem Is Nothing) Then
      If (tvwBitmaps.SelectedItem.Key = "TOP") Then
         pSaveAll
      Else
         Dim sFile As String
         If (VBGetSaveFileName(sFile, _
            Filter:="Bitmap Files (*.BMP)|*.BMP|All Files (*.*)|*.*", _
            DefaultExt:="BMP", _
            Owner:=Me.hwnd)) Then
            pSaveNode tvwBitmaps.SelectedItem, sFile
         End If
      End If
   Else
      MsgBox "Please choose a bitmap.", vbInformation
   End If
End Sub
Private Sub pSaveAll()
   If tvwBitmaps.Nodes.Count > 0 Then
      If (tvwBitmaps.Nodes(1).Children > 0) Then
         Dim cF As New cBrowseForFolder
         cF.hwndOwner = Me.hwnd
         cF.UseNewUI = True
         Dim sFolder As String
         sFolder = cF.BrowseForFolder
         If (Len(sFolder) > 0) Then
            If (Right$(sFolder, 1) <> "\") Then sFolder = sFolder & "\"
            Dim nod As Node
            Dim sFile As String
            Set nod = tvwBitmaps.Nodes(1).Child
            Do
               On Error Resume Next
               sFile = sFolder & nod.Text & ".bmp"
               pSaveNode nod, sFile
               On Error GoTo 0
               Set nod = nod.Next
            Loop While Not (nod Is Nothing)
         End If
      Else
         MsgBox "This resource contains no bitmaps.", vbInformation
      End If
   Else
      MsgBox "Please choose a bitmap.", vbInformation
   End If
   sbrMain.Panels(1) = "Ready."
   Exit Sub

ErrorHandler:
   MsgBox "An error occurred whilst extracting files: " & Err.Description,
    vbInformation
   Exit Sub
End Sub

Private Sub pSaveNode(nod As Node, ByVal sFile As String)
   Dim cDib As cAlphaDibSection
   Dim bColorDepth As Byte
   
   sbrMain.Panels(1).Text = "Extracting " & nod.Text & "..."
   Set cDib = DIBSectionFromResource(m_cLib.hModule, nod.Text,
    m_bPreMultiplyAlpha, bColorDepth)
   If Not cDib Is Nothing Then
      sbrMain.Panels(1).Text = "Saving " & nod.Text & " to " & sFile
      If (m_bAlwaysSaveAlphaChannel) Or (bColorDepth > 24) Then
         cDib.SavePicture sFile
      ElseIf (bColorDepth < 32) Then
         Dim cDib24 As New cDIBSection
         cDib24.Create cDib.Width, cDib.Height
         cDib.PaintPicture cDib24.hdc
         cDib24.SavePicture sFile
      End If
   End If
   
End Sub

Private Sub Form_Load()
   
   m_bPreMultiplyAlpha = False
   
   m_cSplit.Container = picSplit
   m_cSplit.Orientation = cSPLTOrientationVertical
   m_cSplit.Bind tvwBitmaps, picBitmapArea
   
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   picSplit.Move 0, picSplit.Top, Me.ScaleWidth, Me.ScaleHeight - picSplit.Top
    - sbrMain.Height
End Sub

Private Sub mnuFile_Click(Index As Integer)
   Select Case Index
   Case 0
      pOpen
   Case 1
      pSave
   Case 2
      pSaveAll
   Case 4
      Unload Me
   End Select
End Sub

Private Sub mnuOptions_Click(Index As Integer)
   mnuOptions(Index).Checked = Not mnuOptions(Index).Checked
   m_bAlwaysSaveAlphaChannel = mnuOptions(0).Checked
   m_bPreMultiplyAlpha = mnuOptions(1).Checked
End Sub

Private Sub picBitmap_Resize()
   If Not (m_cDib Is Nothing) Then
      picBitmap.Cls
      m_cDib.AlphaPaintPicture picBitmap.hdc, 2, 2
      picBitmap.Refresh
   End If
End Sub

Private Sub picBitmapArea_Resize()
   On Error Resume Next
   fraBitmapInfo.Width = picBitmapArea.ScaleWidth - fraBitmapInfo.Left * 2
   picBitmap.Move 0, picBitmap.Top, picBitmapArea.ScaleWidth,
    picBitmapArea.ScaleHeight - picBitmap.Top
End Sub

Private Sub picSplit_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   m_cSplit.MouseDown Button, Shift, x, y
End Sub

Private Sub picSplit_MouseMove(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   m_cSplit.MouseMove Button, Shift, x, y
End Sub

Private Sub picSplit_MouseUp(Button As Integer, Shift As Integer, x As Single,
 y As Single)
   m_cSplit.MouseUp Button, Shift, x, y
End Sub

Private Sub picSplit_Resize()
   m_cSplit.ResizePanels
End Sub

Private Sub tbrMain_ButtonClick(ByVal Button As ComctlLib.Button)
   Select Case Button.Key
   Case "OPEN"
      pOpen
   Case "SAVE"
      pSave
   End Select
End Sub

Private Sub tvwBitmaps_NodeClick(ByVal Node As ComctlLib.Node)
   pSelectNode
End Sub