vbAccelerator - Contents of code file: ctlIconPicker.ctl

VERSION 5.00
Begin VB.UserControl ctlIconPicker 
   Alignable       =   -1  'True
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   ToolboxBitmap   =   "ctlIconPicker.ctx":0000
   Begin VB.CommandButton cmdBrowse 
      Caption         =   "&Browse..."
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3360
      TabIndex        =   2
      Top             =   300
      Width           =   1335
   End
   Begin VB.TextBox txtFile 
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   60
      TabIndex        =   0
      Top             =   300
      Width           =   3255
   End
   Begin VB.Label lblSelect 
      Caption         =   "Select an icon from the list below:"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   60
      TabIndex        =   3
      Top             =   720
      Width           =   3315
   End
   Begin VB.Label lblLookFor 
      Caption         =   "Look for icons in this file:"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   60
      TabIndex        =   1
      Top             =   60
      Width           =   3315
   End
End
Attribute VB_Name = "ctlIconPicker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Type RECT
   Left As Long
   TOp As Long
   Right As Long
   Bottom As Long
End Type

' Owner draw item measure:
Private Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    ItemId As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type

' Owner draw item draw:
Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    ItemId As Long
    ItemAction As Long
    ItemState As Long
    hwndItem As Long
    hdc As Long
    rcItem As RECT
    itemData As Long
End Type

Private Type ICONDIR
   idReserved As Integer   '// Reserved
   idType As Integer       '// resource type (1 for icons)
   idCount As Integer      '// how many images?
   ' idEntries() as ICONDIRENTRY array follows.
End Type

' Constants:
Private Const WM_SIZE = &H5
Private Const WM_SETFOCUS = &H7
Private Const WM_KILLFOCUS = &H8
Private Const WM_MOUSEACTIVATE = &H21
Private Const WM_DRAWITEM = &H2B
Private Const WM_MEASUREITEM = &H2C
Private Const WM_SETFONT = &H30
Private Const WM_GETFONT = &H31
Private Const WM_COMMAND = &H111
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_CHAR = &H102
'Private Const WM_MOUSEMOVE = &H200
'Private Const WM_LBUTTONDOWN = &H201
'Private Const WM_LBUTTONUP = &H202
'Private Const WM_RBUTTONDOWN = &H204
'Private Const WM_RBUTTONUP = &H205
'Private Const WM_MBUTTONDOWN = &H207
'Private Const WM_MBUTTONUP = &H208
Private Const WM_CTLCOLORLISTBOX = &H134

Private Const WS_HSCROLL = &H100000
Private Const WS_VISIBLE = &H10000000
Private Const WS_CHILD = &H40000000

Private Const WS_EX_CLIENTEDGE = &H200

' List box messages:
Private Const LB_ERR = (-1)

Private Const LB_ADDSTRING = &H180
Private Const LB_RESETCONTENT = &H184
Private Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_SETCOLUMNWIDTH = &H195
Private Const LB_GETITEMDATA = &H199
Private Const LB_SETITEMDATA = &H19A
Private Const LB_SETITEMHEIGHT = &H1A0
Private Const LB_FINDSTRINGEXACT = &H1A2

' List box styles;
Private Const LBS_NOTIFY = &H1&
Private Const LBS_HASSTRINGS = &H40&
Private Const LBS_MULTICOLUMN = &H200&
Private Const LBS_OWNERDRAWFIXED = &H10&

' List box notification messages:
Private Const LBN_DBLCLK = 2
Private Const LBN_ERRSPACE = (-2)
Private Const LBN_KILLFOCUS = 5
Private Const LBN_SELCANCEL = 3
Private Const LBN_SELCHANGE = 1
Private Const LBN_SETFOCUS = 4

' Owner draw style types:
Private Const ODS_CHECKED = &H8
Private Const ODS_DISABLED = &H4
Private Const ODS_FOCUS = &H10
Private Const ODS_GRAYED = &H2
Private Const ODS_SELECTED = &H1

' Show window:
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5

' mouse activate responses
Private Const MA_ACTIVATE = 1
Private Const MA_ACTIVATEANDEAT = 2
Private Const MA_NOACTIVATE = 3
Private Const MA_NOACTIVATEANDEAT = 4

' Virtual key code constants:
Private Const VK_SHIFT = &H10&
Private Const VK_CONTROL = &H11&
Private Const VK_MENU = &H12& ' Alt key

' Set window pos
Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send
 WM_NCCALCSIZE
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_SHOWWINDOW = &H40

' Creating new windows:
Private Declare Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA"
 (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As
 String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth
 As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long,
 ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "USER32" (ByVal hwnd As Long) As Long

' Focus
Private Declare Function SetFocusAPI Lib "USER32" Alias "SetFocus" (ByVal hwnd
 As Long) As Long
Private Declare Function GetFocus Lib "USER32" () As Long

Private Declare Function ShowWindow Lib "USER32" (ByVal hwnd As Long, ByVal
 nCmdShow As Long) As Long
Private Declare Function MoveWindow Lib "USER32" (ByVal hwnd As Long, ByVal x
 As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 bRepaint As Boolean) As Long
Private Declare Function SetWindowPos Lib "USER32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetParent Lib "USER32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long
Private Declare Function GetParent Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "USER32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function ClientToScreen Lib "USER32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "USER32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function ChildWindowFromPoint Lib "USER32" (ByVal hWndParent As
 Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function InvalidateRect Lib "USER32" (ByVal hwnd As Long,
 lpRect As RECT, ByVal bErase As Long) As Long

' Message functions:
Private Declare Function SendMessageByString Lib "USER32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 String) As Long
Private Declare Function SendMessageByLong Lib "USER32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal
 hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function PostMessage Lib "USER32" Alias "PostMessageA" (ByVal
 hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
 As Long

' GDI
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function GetSysColorBrush Lib "USER32" (ByVal nIndex As Long)
 As Long
Private Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long

' Key functions:
Private Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As
 Integer
'
' General
Private Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long)
 As Long
Private Const SM_CYHSCROLL = 3

' SHAutoComplete:
Private Enum SHAutoCompleteFlags
   SHACF_DEFAULT = &H0                           ' // Currently
    (SHACF_FILESYSTEM | SHACF_URLALL)
   SHACF_FILESYSTEM = &H1                        ' // This includes the File
    System as well as the rest of the shell (Desktop\My Computer\Control Panel\)
   SHACF_URLHISTORY = &H2                        ' // URLs in the User's History
   SHACF_URLMRU = &H4                            ' // URLs in the User's
    Recently Used list.
   SHACF_USETAB = &H8                            ' // Use the tab to move thru
    the autocomplete possibilities instead of to the next dialog/window control.
   SHACF_URLALL = (SHACF_URLHISTORY Or SHACF_URLMRU)
   SHACF_FILESYS_ONLY = &H10                     ' // This includes the File
    System
   SHACF_FILESYS_DIRS = &H20                     ' // Same as
    SHACF_FILESYS_ONLY except it only includes directories, UNC servers, and
    UNC server shares.
   SHACF_AUTOSUGGEST_FORCE_ON = &H10000000       ' // Ignore the registry
    default and force the feature on.
   SHACF_AUTOSUGGEST_FORCE_OFF = &H20000000      ' // Ignore the registry
    default and force the feature off.
   SHACF_AUTOAPPEND_FORCE_ON = &H40000000        ' // Ignore the registry
    default and force the feature on. (Also know as AutoComplete)
   SHACF_AUTOAPPEND_FORCE_OFF = &H80000000       ' // Ignore the registry
    default and force the feature off. (Also know as AutoComplete)
End Enum
Private Declare Function SHAutoComplete Lib "shlwapi.dll" ( _
   ByVal hwndEdit As Long, ByVal dwFlags As Long) As Long

' Extracting icons:
Private Declare Function ExtractIconEx Lib "Shell32" Alias "ExtractIconExA" ( _
      ByVal lpszFile As String, _
      ByVal nIconIndex As Long, _
      plIconLarge As Long, _
      plIconSmall As Long, _
      ByVal nIcons As Long _
   ) As Long
Private Declare Function DestroyIcon Lib "USER32" (ByVal hIcon As Long) As Long


' Subclassing support:
Implements ISubclass

' Over-riding VB UserControl's default IOLEInPlaceActivate:
Private m_IPAOHookStruct As IPAOHookStruct

' Handle of ListBox:
Private m_hWnd As Long
' Handle of user control:
Private m_hWndParent As Long
' design time?
Private m_bDesignMode As Boolean
' Font
Private m_fnt As IFont
' BackColour brush
Private m_hBackBrush As Long
' Top of listBox:
Private m_lTop As Long
' icons:
Private m_hIml As Long
Private m_lIconWidth As Long
Private m_lIconHeight As Long

Private m_lNewItem As Long

Private m_sFileName As String
Private m_bAllowChangeFileName As Boolean

Private m_cIml As pcVBALImageList

Public Event DblClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event SelectionChange()


Public Sub AddIcon(sPic As StdPicture, ByVal sKey As String)
Dim iCount As Long
Dim lR As Long

   iCount = m_cIml.ImageCount
   m_cIml.AddFromHandle sPic.Handle, IMAGE_ICON
   If (m_cIml.ImageCount > iCount) Then
      lR = SendMessageByString(m_hWnd, LB_ADDSTRING, 0, sKey)
      If (lR > LB_ERR) Then
         m_lNewItem = lR
         SendMessageByLong m_hWnd, LB_SETITEMDATA, lR, m_cIml.ImageCount
         SendMessageByLong m_hWnd, LB_SETITEMHEIGHT, lR, m_cIml.IconSizeX + 4
      Else
         Debug.Print "Problem."
      End If
   End If
End Sub

Public Property Get SelectedIconResourceId() As String
Dim lIndex As Long
Dim lLen As Long
Dim sBuf As String
   If Not (m_hWnd = 0) Then
      lIndex = SendMessageByLong(m_hWnd, LB_GETCURSEL, 0, 0)
      If (lIndex > -1) Then
         lLen = SendMessageByLong(m_hWnd, LB_GETTEXTLEN, lIndex, 0)
         If (lLen <> LB_ERR) Then
            If (lLen > 0) Then
               sBuf = String$((lLen), 0)
               SendMessageByString m_hWnd, LB_GETTEXT, lIndex, sBuf
               SelectedIconResourceId = sBuf
            End If
         End If
      End If
   End If
End Property

Public Property Let SelectedIconResourceId(ByVal sName As String)
Dim lR As Long
   ' find the matching item in the control:
   If Not (m_hWnd = 0) Then
      lR = SendMessageByString(m_hWnd, LB_FINDSTRINGEXACT, 0, sName)
      If (lR > 0) Then
         SendMessageByLong m_hWnd, LB_SETCURSEL, lR, 0
      End If
   End If
End Property

Public Property Get SelectedIcon() As IPicture
Dim lIndex As Long
Dim lLen As Long
   lIndex = SendMessageByLong(m_hWnd, LB_GETCURSEL, 0, 0)
   If (lIndex > -1) Then
      Set SelectedIcon = m_cIml.ItemPicture(lIndex + 1)
   End If
End Property

Public Property Get AllowChangeFile() As Boolean
   AllowChangeFile = m_bAllowChangeFileName
End Property
Public Property Let AllowChangeFile(ByVal bState As Boolean)
   If Not (bState = m_bAllowChangeFileName) Then
      m_bAllowChangeFileName = bState
      lblLookFor.Visible = bState
      txtFile.Visible = bState
      lblSelect.Visible = bState
      cmdBrowse.Visible = bState
      UserControl_Resize
      PropertyChanged "AllowChangeFile"
   End If
End Property

Public Property Get Font() As IFont
   Set Font = m_fnt
End Property
Public Property Let Font(ByVal iFnt As IFont)
   pSetFont iFnt
   PropertyChanged "Font"
End Property
Public Property Set Font(ByVal iFnt As IFont)
   pSetFont iFnt
   PropertyChanged "Font"
End Property

Public Property Get ScaleMode() As ScaleModeConstants
   ScaleMode = UserControl.ScaleMode
End Property
Public Property Let ScaleMode(ByVal eMode As ScaleModeConstants)
   If Not (UserControl.ScaleMode = eMode) Then
      UserControl.ScaleMode = eMode
      PropertyChanged "ScaleMode"
   End If
End Property
Public Property Get ScaleX(x As Single, fromScale As ScaleModeConstants,
 toScale As ScaleModeConstants)
   ScaleX = UserControl.ScaleX(x, fromScale, toScale)
End Property
Public Property Get ScaleY(y As Single, fromScale As ScaleModeConstants,
 toScale As ScaleModeConstants)
   ScaleY = UserControl.ScaleY(y, fromScale, toScale)
End Property

Private Sub pSetFont(iFnt As IFont)
   Set m_fnt = iFnt
   Set lblLookFor.Font = m_fnt
   Set cmdBrowse.Font = m_fnt
   Set lblSelect.Font = m_fnt
   If Not (m_hWnd = 0) Then
      ' Ensure the control has the correct font:
      SendMessageByLong m_hWnd, WM_SETFONT, m_fnt.hFont, 1
   End If
End Sub

Private Sub Clear()
   '
   If Not (m_hWnd = 0) Then
      SendMessageByLong m_hWnd, LB_RESETCONTENT, 0, 0
      SendMessageByLong m_hWnd, LB_SETCOLUMNWIDTH, m_lIconWidth + 4, 0
   End If
   ' Set last added item to -1:
   m_lNewItem = -1
   '
End Sub

Public Property Get Filename() As String
   Filename = m_sFileName
End Property


Public Property Let Filename(ByVal sFileName As String)
   If Not (StrComp(sFileName, m_sFileName) = 0) Then
      
      m_sFileName = sFileName
      If Not m_cIml Is Nothing Then
         m_cIml.Clear
      End If
      Clear
      
      Screen.MousePointer = vbHourglass
      ShowWindow m_hWnd, SW_HIDE
      m_sFileName = sFileName
      If Len(m_sFileName) > 0 Then
         'GetIconResources Me, m_sFileName
         extractIcons m_sFileName
      End If
      If (m_cIml.ImageCount = 0) Then
         ' Is this file an icon file?
         GetIconFromIconFile
      End If
      
      ShowWindow m_hWnd, SW_SHOW
      Screen.MousePointer = vbDefault
      
      SelectedIconResourceId = SelectedIconResourceId
      
      txtFile.Text = sFileName
      PropertyChanged "FileName"
   End If
   
End Property

Private Sub extractIcons(ByVal sFile As String)
Dim iconCount As Long
   iconCount = ExtractIconEx( _
            sFile, -1, ByVal 0, ByVal 0, 0)
   If (iconCount > 0) Then
      ReDim hIconlarge(0 To iconCount - 1) As Long
      iconCount = ExtractIconEx( _
               sFile, 0, hIconlarge(0), ByVal 0, iconCount)
      Dim i As Long
      Dim lR As Long
      For i = 0 To iconCount - 1
         m_cIml.AddFromHandle hIconlarge(i), IMAGE_ICON
         DestroyIcon hIconlarge(i)
         lR = SendMessageByString(m_hWnd, LB_ADDSTRING, 0, i)
         If (lR > LB_ERR) Then
            m_lNewItem = lR
            SendMessageByLong m_hWnd, LB_SETITEMDATA, lR, m_cIml.ImageCount
            SendMessageByLong m_hWnd, LB_SETITEMHEIGHT, lR, m_cIml.IconSizeX + 4
         Else
            Debug.Print "Problem."
         End If
      Next i
   End If
End Sub

Private Sub GetIconFromIconFile()
Dim iCount As Long
Dim lR As Long
   iCount = m_cIml.ImageCount
   On Error Resume Next
   m_cIml.AddFromFile m_sFileName, IMAGE_ICON
   On Error GoTo 0
   If (m_cIml.ImageCount > iCount) Then
      lR = SendMessageByString(m_hWnd, LB_ADDSTRING, 0, "")
      If (lR > LB_ERR) Then
         m_lNewItem = lR
         SendMessageByLong m_hWnd, LB_SETITEMDATA, lR, m_cIml.ImageCount
         SendMessageByLong m_hWnd, LB_SETITEMHEIGHT, lR, m_cIml.IconSizeX + 4
      Else
         Debug.Print "Problem."
      End If
   End If

End Sub

Private Sub pInitialise()
Dim hInst As Long
Dim sStyle As String
Dim wStyle As Long
Dim lW As Long, lH As Long
          
   ' If we already have a window, then destroy it:
   pTerminate
   
   m_bDesignMode = Not (UserControl.Ambient.UserMode)
   
   If Not m_bDesignMode Then
      ' Start auto-complete on the text box:
      On Error Resume Next ' may not be supported
      SHAutoComplete txtFile.hwnd, SHACF_FILESYS_ONLY
      On Error GoTo 0
   
      ' Create the combo box:
      hInst = App.hInstance
      
      ' Set up style bits to get the appropriate type of
      ' window:
      sStyle = "LISTBOX"
      wStyle = WS_VISIBLE Or WS_CHILD
      wStyle = wStyle Or LBS_HASSTRINGS Or LBS_OWNERDRAWFIXED Or LBS_NOTIFY Or
       LBS_MULTICOLUMN
      wStyle = wStyle Or WS_HSCROLL
      lH = 48
      ' Create the window:
      lW = UserControl.Width \ Screen.TwipsPerPixelX
      m_hWndParent = UserControl.hwnd
      m_hWnd = CreateWindowEx( _
          WS_EX_CLIENTEDGE, _
          sStyle, _
          "", _
          wStyle, _
          0, 0, lW, lH, _
          m_hWndParent, _
          0, _
          hInst, _
          ByVal 0 _
          )
      ' If we succeed
      If Not (m_hWnd = 0) Then
         m_hBackBrush = GetSysColorBrush(vbWindowBackground And &H1F&)
      
         ' Ensure the correct font:
         pSetFont m_fnt
         
         ' Start subclassing:
         pSubClass
         
         ' Create the Image List:
         Set m_cIml = New pcVBALImageList
         m_cIml.IconSizeX = 32
         m_cIml.IconSizeY = 32
         m_cIml.ColourDepth = ILC_COLOR32
         
         m_lIconWidth = m_cIml.IconSizeX
         m_lIconHeight = m_cIml.IconSizeY
                  
      End If
           
   End If
   
End Sub
Private Sub pSubClass()
   If Not (m_bDesignMode) Then
      AttachMessage Me, m_hWndParent, WM_SIZE
      AttachMessage Me, m_hWndParent, WM_COMMAND
      AttachMessage Me, m_hWndParent, WM_MEASUREITEM
      AttachMessage Me, m_hWndParent, WM_DRAWITEM
      AttachMessage Me, m_hWndParent, WM_CTLCOLORLISTBOX
      AttachMessage Me, m_hWndParent, WM_SETFOCUS
      AttachMessage Me, m_hWndParent, WM_GETFONT
      AttachMessage Me, m_hWnd, WM_KEYDOWN
      AttachMessage Me, m_hWnd, WM_CHAR
      AttachMessage Me, m_hWnd, WM_KEYUP
      AttachMessage Me, m_hWnd, WM_SETFOCUS
      AttachMessage Me, m_hWnd, WM_MOUSEACTIVATE
      'AttachMessage Me, m_hWnd, WM_LBUTTONDOWN
      'AttachMessage Me, m_hWnd, WM_MBUTTONDOWN
      'AttachMessage Me, m_hWnd, WM_RBUTTONDOWN
      'AttachMessage Me, m_hWnd, WM_MOUSEMOVE
      'AttachMessage Me, m_hWnd, WM_LBUTTONUP
      'AttachMessage Me, m_hWnd, WM_MBUTTONUP
      'AttachMessage Me, m_hWnd, WM_RBUTTONUP
   End If
End Sub
Private Sub pUnSubClass()
   If Not (m_hWndParent = 0) Then
      DetachMessage Me, m_hWndParent, WM_SIZE
      DetachMessage Me, m_hWndParent, WM_COMMAND
      DetachMessage Me, m_hWndParent, WM_MEASUREITEM
      DetachMessage Me, m_hWndParent, WM_DRAWITEM
      DetachMessage Me, m_hWndParent, WM_CTLCOLORLISTBOX
      DetachMessage Me, m_hWndParent, WM_SETFOCUS
      DetachMessage Me, m_hWndParent, WM_GETFONT
   End If
   If Not (m_hWnd = 0) Then
      DetachMessage Me, m_hWnd, WM_KEYDOWN
      DetachMessage Me, m_hWnd, WM_CHAR
      DetachMessage Me, m_hWnd, WM_KEYUP
      DetachMessage Me, m_hWnd, WM_SETFOCUS
      DetachMessage Me, m_hWnd, WM_MOUSEACTIVATE
      'detachMessage Me, m_hWnd, WM_LBUTTONDOWN
      'detachMessage Me, m_hWnd, WM_MBUTTONDOWN
      'detachMessage Me, m_hWnd, WM_RBUTTONDOWN
      'detachMessage Me, m_hWnd, WM_MOUSEMOVE
      'detachMessage Me, m_hWnd, WM_LBUTTONUP
      'detachMessage Me, m_hWnd, WM_MBUTTONUP
      'detachMessage Me, m_hWnd, WM_RBUTTONUP
   End If
End Sub

Private Sub pTerminate()
   
   ' Stop subclassing:
   pUnSubClass
   
   ' Clear the window
   If (m_hWnd <> 0) Then
      ShowWindow m_hWnd, SW_HIDE
      SetParent m_hWnd, 0
      DestroyWindow m_hWnd
   End If
   m_hWnd = 0
   m_hWndParent = 0
   
   ' Clear background brush if we have one:
   If (m_hBackBrush <> 0) Then
      DeleteObject m_hBackBrush
   End If


End Sub


Private Sub pRefreshControl()
Dim tR As RECT
    ' Invalidate the control so it gets redrawn:
    If (m_hWnd <> 0) Then
        tR.Right = UserControl.ScaleWidth \ Screen.TwipsPerPixelX
        tR.Bottom = UserControl.ScaleHeight \ Screen.TwipsPerPixelY
        InvalidateRect m_hWnd, tR, 1
    End If
End Sub

Private Sub cmdBrowse_Click()
   Dim cFB As New pcCommonDialog
   Dim sFile As String
   Dim sOrigFile As String
   If (cFB.VBGetOpenFileName( _
         Filename:=sFile, _
         Filter:="Icon Files|*.ICO;*.EXE;*.DLL|Program Files|*.EXE|Library
          Files|*.DLL|Icons|*.ICO|All Files|*.*", _
         DefaultExt:="EXE", _
         Owner:=UserControl.hwnd)) Then
      sOrigFile = m_sFileName
      Filename = sFile
      txtFile.Text = sFile
      If (m_cIml.ImageCount <= 0) Then
         MsgBox "The file '" & sFile & "' contains no icons", vbExclamation
      End If
   End If
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
   ' Not required.
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   Select Case CurrentMessage
   Case WM_MOUSEACTIVATE ' WM_CHAR, WM_KEYDOWN
      ISubclass_MsgResponse = emrConsume
   Case Else
      ISubclass_MsgResponse = emrPreprocess
   End Select
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lW As Long
Dim lH As Long
Dim iKeyCode As Integer
      
   Select Case iMsg
   Case WM_CTLCOLORLISTBOX
      If (m_hBackBrush <> 0) Then
         ISubclass_WindowProc = m_hBackBrush
      End If
      
   Case WM_MEASUREITEM
       ISubclass_WindowProc = plMeasureItem(wParam, lParam)

   Case WM_DRAWITEM
       ISubclass_WindowProc = plDrawItem(wParam, lParam)

   Case WM_COMMAND
      If (plNotificationEvent(hwnd, iMsg, wParam, lParam) <> 0) Then
         ISubclass_WindowProc = 1
      End If
      
   Case WM_GETFONT
      ISubclass_WindowProc = m_fnt.hFont
      
   Case WM_SIZE
      lW = (lParam And &HFFFF&)
      lH = ((lParam \ &H10000) And &HFFFF&)
      pResize lW, lH
      
   Case WM_KEYDOWN, WM_CHAR, WM_KEYUP
      If (plKeyEvent(hwnd, iMsg, wParam, lParam) = 1) Then
         ISubclass_WindowProc = 1
      End If

      
'   Case WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN
'      iButton = (Abs(iMsg = WM_LBUTTONDOWN)) * vbLeftButton + (Abs(iMsg =
 WM_RBUTTONDOWN)) * vbRightButton + (Abs(iMsg = WM_MBUTTONDOWN)) *
 vbMiddleButton
'      iShift = wParam
'      If (lParam And &H8000&) = &H8000& Then
'         x = -(&H8000& - (lParam And &H7FFF&))
'      Else
'         x = (lParam And &HFFFF&)
'      End If
'      If (lParam And &H80000000) = &H80000000 Then
'         y = -(&H8000& - (lParam And &H7FFF0000) \ &H10000)
'      Else
'         y = (lParam \ &H10000)
'      End If
'      RaiseEvent MouseDown(iButton, iShift, x, y)
'
'   Case WM_MOUSEMOVE
'      iButton = Abs(GetAsyncKeyState(vbKeyLButton) <> 0) * vbLeftButton +
 Abs(GetAsyncKeyState(vbKeyRButton) <> 0) * vbRightButton +
 Abs(GetAsyncKeyState(vbKeyMButton) <> 0) * vbMiddleButton
'      iShift = wParam
'      If (lParam And &H8000&) = &H8000& Then
'         x = -(&H8000& - (lParam And &H7FFF&))
'      Else
'         x = (lParam And &HFFFF&)
'      End If
'      If (lParam And &H80000000) = &H80000000 Then
'         y = -(&H8000& - (lParam And &H7FFF0000) \ &H10000)
'      Else
'         y = (lParam \ &H10000)
'      End If
'      RaiseEvent MouseMove(iButton, iShift, x, y)
      
'   Case WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
'      iButton = (Abs(iMsg = WM_LBUTTONDOWN)) * vbLeftButton + (Abs(iMsg =
 WM_RBUTTONDOWN)) * vbRightButton + (Abs(iMsg = WM_MBUTTONDOWN)) *
 vbMiddleButton
'      iShift = wParam
'      If (lParam And &H8000&) = &H8000& Then
'         x = -(&H8000& - (lParam And &H7FFF&))
'      Else
'         x = (lParam And &HFFFF&)
'      End If
'      If (lParam And &H80000000) = &H80000000 Then
'         y = -(&H8000& - (lParam And &H7FFF0000) \ &H10000)
'      Else
'         y = (lParam \ &H10000)
'      End If
'      RaiseEvent MouseUp(iButton, iShift, x, y)
      
   '
    ----------------------------------------------------------------------------
   --
   ' Implement focus.  Many many thanks to Mike Gainer for showing me this
   ' code.
   Case WM_SETFOCUS
      If (m_hWnd = hwnd) Then
         ' The list box itself
         Dim pOleObject                  As IOleObject
         Dim pOleInPlaceSite             As IOleInPlaceSite
         Dim pOleInPlaceFrame            As IOleInPlaceFrame
         Dim pOleInPlaceUIWindow         As IOleInPlaceUIWindow
         Dim pOleInPlaceActiveObject     As IOleInPlaceActiveObject
         Dim PosRect                     As RECT
         Dim ClipRect                    As RECT
         Dim FrameInfo                   As OLEINPLACEFRAMEINFO
         Dim grfModifiers                As Long
         Dim AcceleratorMsg              As MSG
         
         'Get in-place frame and make sure it is set to our in-between
         'implementation of IOleInPlaceActiveObject in order to catch
         'TranslateAccelerator calls
         Set pOleObject = Me
         Set pOleInPlaceSite = pOleObject.GetClientSite
         pOleInPlaceSite.GetWindowContext pOleInPlaceFrame,
          pOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect),
          VarPtr(FrameInfo)
         CopyMemory pOleInPlaceActiveObject, m_IPAOHookStruct.ThisPointer, 4
         pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString
         If Not pOleInPlaceUIWindow Is Nothing Then
            pOleInPlaceUIWindow.SetActiveObject pOleInPlaceActiveObject,
             vbNullString
         End If
         CopyMemory pOleInPlaceActiveObject, 0&, 4
      Else
         ' The user control:
         SetFocusAPI m_hWnd
      End If
      
   Case WM_MOUSEACTIVATE
      If Not GetFocus() = m_hWnd Then
         SetFocusAPI m_hWndParent
         ISubclass_WindowProc = MA_NOACTIVATE
         Exit Function
      Else
         ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
      End If
   ' End Implement focus.
   '
    ----------------------------------------------------------------------------
   --
   
   End Select
   
End Function

Private Function plNotificationEvent(ByVal lhWnd As Long, ByVal iMsg As
 Integer, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lHiWord As Long, lLoWord As Long
Dim tR As RECT

   If (lParam = m_hWnd) Then
      pGetHiWordLoWord wParam, lHiWord, lLoWord
      Select Case lHiWord
      Case LBN_DBLCLK
         RaiseEvent DblClick
      Case LBN_SETFOCUS
      Case LBN_KILLFOCUS
      Case LBN_SELCHANGE
         RaiseEvent SelectionChange
      Case LBN_SELCANCEL
      End Select
   End If
   
End Function
Private Function plKeyEvent(ByVal lhWnd As Long, ByVal iMsg As Integer, ByVal
 wParam As Long, ByVal lParam As Long) As Long
Dim iKeyCode As Integer
Dim iKeyAscii As Integer
Dim iOrigKeyAscii As Integer
Dim iShift As Integer

   If (lhWnd = m_hWnd) Then
      iKeyCode = (wParam And &HFF)
      ' Alt key pressed = Bit 29
      If ((lParam And &H20000000) = &H20000000) Then
          iShift = 1
      End If
      Select Case iMsg
      Case WM_KEYDOWN
          iShift = piGetShiftState()
          RaiseEvent KeyDown(iKeyCode, iShift)
      Case WM_KEYUP
          iShift = piGetShiftState()
          RaiseEvent KeyUp(iKeyCode, iShift)
      Case WM_CHAR
          iKeyAscii = (wParam And &HFF)
          iOrigKeyAscii = iKeyAscii
          RaiseEvent KeyPress(iKeyAscii)
          If (iKeyAscii = 0) Then
              plKeyEvent = 1
          ElseIf (iKeyAscii <> iOrigKeyAscii) Then
              SendMessageByLong lhWnd, WM_CHAR, iKeyAscii, 0
              plKeyEvent = 1
          End If
      End Select
   End If
   
End Function
Private Function plMeasureItem(ByVal wParam As Long, ByVal lParam As Long) As
 Long
Dim tMIs As MEASUREITEMSTRUCT
   CopyMemory tMIs, ByVal lParam, Len(tMIs)
   tMIs.itemWidth = m_lIconWidth + 4
   tMIs.itemHeight = m_lIconHeight + 4
   CopyMemory ByVal lParam, tMIs, Len(tMIs)
   plMeasureItem = 1
End Function
Private Function plDrawItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tDis As DRAWITEMSTRUCT
Dim bEnabled As Boolean
Dim bSelected As Boolean
Dim hBrBack As Long
Dim lLeft As Long
Dim lTop As Long

   
   CopyMemory tDis, ByVal lParam, Len(tDis)
   
   ' Evaluate enabled/selected state of item:
   bSelected = ((tDis.ItemState And ODS_SELECTED) = ODS_SELECTED)

   ' Choose the background colour:
   If (bSelected) Then
      hBrBack = GetSysColorBrush(vbHighlight And &H1F&)
   Else
      hBrBack = GetSysColorBrush(vbWindowBackground And &H1F&)
   End If
   ' Fill the background:
   FillRect tDis.hdc, tDis.rcItem, hBrBack
   DeleteObject hBrBack
   
   ' Draw the icon:
   On Error Resume Next
   lLeft = tDis.rcItem.Left + (tDis.rcItem.Right - tDis.rcItem.Left -
    m_lIconWidth) \ 2
   If Not (Err.Number = 0) Then
      Debug.Print "LLEFT", Err.Number, Err.Description
      Err.Clear
   End If
   lTop = tDis.rcItem.TOp + (tDis.rcItem.Bottom - tDis.rcItem.TOp -
    m_lIconHeight) \ 2
   If Not (Err.Number = 0) Then
      Debug.Print "LTOP", Err.Number, Err.Description
      Err.Clear
   End If
   m_cIml.DrawImage tDis.itemData, tDis.hdc, lLeft, lTop
   If Not (Err.Number = 0) Then
      Debug.Print "DRAWIMAGE", Err.Number, Err.Description
   End If
   

End Function

Private Function piGetShiftState() As Integer
Dim iR As Integer
Dim lR As Long
Dim lKey As Long
    iR = iR Or (-1 * pbKeyIsPressed(VK_SHIFT))
    iR = iR Or (-2 * pbKeyIsPressed(VK_MENU))
    iR = iR Or (-4 * pbKeyIsPressed(VK_CONTROL))
    piGetShiftState = iR

End Function
Private Function pbKeyIsPressed( _
        ByVal nVirtKeyCode As KeyCodeConstants _
    ) As Boolean
Dim lR As Long
    lR = GetAsyncKeyState(nVirtKeyCode)
    If (lR And &H8000&) = &H8000& Then
        pbKeyIsPressed = True
    End If
End Function

Private Sub pGetHiWordLoWord( _
        ByVal lValue As Long, _
        ByRef lHiWord As Long, _
        ByRef lLoWord As Long _
    )
    lHiWord = lValue \ &H10000
    lLoWord = (lValue And &HFFFF&)
End Sub

Private Sub pResize(ByVal lW As Long, ByVal lH As Long)
   If Not (m_hWnd = 0) Then
      If (m_bAllowChangeFileName) Then
         SetWindowPos m_hWnd, 0, UserControl.ScaleX(txtFile.Left,
          UserControl.ScaleMode, vbPixels), m_lTop, lW - 4, lH - m_lTop - 2,
          SWP_FRAMECHANGED Or SWP_NOOWNERZORDER Or SWP_SHOWWINDOW
      Else
         SetWindowPos m_hWnd, 0, 2, 2, lW - 4, lH - 4, SWP_FRAMECHANGED Or
          SWP_NOOWNERZORDER Or SWP_SHOWWINDOW
      End If
   End If
End Sub

Friend Function fTranslateAccelerator(lpMsg As VBOleGuids.MSG) As Long
    
   fTranslateAccelerator = S_FALSE
   ' Here you can modify the response to the key down
   ' accelerator command using the values in lpMsg.  This
   ' can be used to capture Tabs, Returns, Arrows etc.
   ' Just process the message as required and return S_OK.
   If lpMsg.message = WM_KEYDOWN Then
      Select Case lpMsg.wParam And &HFFFF&
      Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown,
       vbKeyPageUp, vbKeyHome, vbKeyEnd, vbKeyReturn
         SendMessageByLong m_hWnd, lpMsg.message, lpMsg.wParam, lpMsg.lParam
         fTranslateAccelerator = S_OK
      End Select
   End If
   
End Function

Private Sub UserControl_Initialize()
   '
   ' Attach custom IOleInPlaceActiveObject interface
   Dim IPAO As IOleInPlaceActiveObject

   With m_IPAOHookStruct
      Set IPAO = Me
      CopyMemory .IPAOReal, IPAO, 4
      CopyMemory .TBEx, Me, 4
      .lpVTable = IPAOVTable
      .ThisPointer = VarPtr(m_IPAOHookStruct)
   End With
   
   Dim sF As New StdFont
   sF.Name = "Tahoma"
   sF.Size = 8.25
   Set m_fnt = sF
   m_bAllowChangeFileName = True
   
   '
End Sub

Private Sub UserControl_InitProperties()
   '
   pInitialise
   '
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   '
   pInitialise
   
   m_bAllowChangeFileName = PropBag.ReadProperty("AllowChangeFileName", True)
   Filename = PropBag.ReadProperty("FileName", "")
   Font = PropBag.ReadProperty("Font", m_fnt)
   ScaleMode = PropBag.ReadProperty("ScaleMode", vbTwips)
   
   '
End Sub

Private Sub UserControl_Resize()
On Error Resume Next
   If (m_bAllowChangeFileName) Then
      m_lTop = UserControl.ScaleY(lblSelect.TOp + lblSelect.Height,
       UserControl.ScaleMode, vbPixels)
      txtFile.Width = UserControl.ScaleWidth - txtFile.Left - cmdBrowse.Width -
       UserControl.ScaleX(4, vbPixels, UserControl.ScaleMode)
      cmdBrowse.Left = txtFile.Width + txtFile.Left + UserControl.ScaleX(2,
       vbPixels, UserControl.ScaleMode)
      lblLookFor.Width = UserControl.ScaleWidth - lblLookFor.Left * 2
      lblSelect.Width = lblLookFor.Width
   Else
      m_lTop = 2
   End If
   Dim tR As RECT
   GetClientRect UserControl.hwnd, tR
   pResize tR.Right - tR.Left, tR.Bottom - tR.TOp
End Sub

Private Sub UserControl_Show()
   UserControl_Resize
End Sub

Private Sub UserControl_Terminate()
   '
   pTerminate
   
   ' detach pointers.
   With m_IPAOHookStruct
      CopyMemory .IPAOReal, 0&, 4
      CopyMemory .TBEx, 0&, 4
   End With

   '
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   '
   PropBag.WriteProperty "AllowChangeFileName", m_bAllowChangeFileName, True
   PropBag.WriteProperty "FileName", Filename, ""
   Dim sF As New StdFont
   sF.Name = "Tahoma"
   sF.Size = 8.25
   PropBag.WriteProperty "Font", Font, sF
   PropBag.WriteProperty "ScaleMode", ScaleMode, vbTwips
   '
End Sub