FixIcon.bas

   1 Attribute VB_Name = "FixWindowIcon"\r
   2 Option Explicit\r
   3 \r
   4 Private Const WM_SETICON = &H80\r
   5 Private Const ICON_SMALL = 0\r
   6 Private Const IMAGE_ICON = 1\r
   7 Private Const LR_DEFAULTSIZE = &H40\r
   8 \r
   9 Private Declare Function GetModuleHandle Lib "Kernel32.dll" _\r
  10     Alias "GetModuleHandleA" _\r
  11     (ByRef lpModuleName As Any) As Long\r
  12 Private Declare Function LoadImage Lib "User32.dll" _\r
  13     Alias "LoadImageA" ( _\r
  14     ByVal hinst As Long, _\r
  15     ByRef lpszName As Any, _\r
  16     ByVal uType As Long, _\r
  17     ByVal cxDesired As Long, _\r
  18     ByVal cyDesired As Long, _\r
  19     ByVal fuLoad As Long) As Long\r
  20 Private Declare Function SendMessageA Lib _\r
  21     "User32.dll" _\r
  22     (ByVal hWnd As Long, _\r
  23     ByVal Msg As Long, _\r
  24     ByVal Wp As Long, _\r
  25     Lp As Any) As Long\r
  26 \r
  27 Sub FixIcon(hWnd As Long, lpszName)\r
  28 Dim hModule As Long, hIcon As Long, szName As String, nName As Long, Width As Long, Height As Long\r
  29 hModule = GetModuleHandle(ByVal 0&)\r
  30 If hModule = 0 Then Exit Sub\r
  31 Width = Abs(GetReg("HKEY_USERS\.Default\Control Panel\Desktop\WindowMetrics\CaptionWidth", -270)) / Screen.TwipsPerPixelX - 2\r
  32 Height = Abs(GetReg("HKEY_USERS\.Default\Control Panel\Desktop\WindowMetrics\CaptionHeight", -270)) / Screen.TwipsPerPixelY - 2\r
  33 If VarType(lpszName) = vbString Then\r
  34     szName = lpszName\r
  35     hIcon = LoadImage(hModule, szName, IMAGE_ICON, Width, Height, LR_DEFAULTSIZE)\r
  36 ElseIf VarType(lpszName) = vbByte Or VarType(lpszName) = vbInteger Or VarType(lpszName) = vbLong Then\r
  37     nName = lpszName\r
  38     hIcon = LoadImage(hModule, ByVal nName, IMAGE_ICON, Width, Height, LR_DEFAULTSIZE)\r
  39 End If\r
  40 If hIcon = 0 Then Exit Sub\r
  41 SendMessageA hWnd, WM_SETICON, ICON_SMALL, ByVal hIcon\r
  42 End Sub\r