Как вытягивать системные иконки типа SIID_SHIELD и вставлять в меню. - VB

Формулировка задачи:

Поразвлекся.
Научился вытягивать системные иконки (они на каждой OS свои).
А то все в ресурсы обычно кладу.
Особенно радует значок "Run As Admin".
Наваял тест-проект, м.б. кому интересно -приложен.
На XP это не работает, на всех новых без проблем.
SHGetStockIconInfo function

'Shell Constants, Enumerations, and Flags
Public Enum SHSTOCKICONID
...
  SIID_FOLDER = 3
...
  SIID_PRINTER = 16
...
  SIID_SHIELD = 77
  SIID_WARNING = 78
  SIID_INFO = 79
  SIID_ERROR = 80
...
 End Enum

'Shell Structures

Private Type SHSTOCKICONINFO
  cbSize As Long
  hIcon As Long
  iSysImageIndex As Long
  iIcon As Long
  szPath(2 * MAX_PATH - 1) As Byte ' W-version ?
End Type

'uFlags - flags that specify which information is requested
Public Const SHGSI_ICON = &H100
Public Const SHGSI_LARGEICON = &H0
Public Const SHGSI_SMALLICON = &H1

'Shell Functions
Public Declare Function SHGetStockIconInfo Lib "Shell32.dll" (ByVal siid As SHSTOCKICONID, _
 ByVal uFlags As Long, ByRef psii As SHSTOCKICONINFO) As Long

Public Function GetStockIcon(ByVal siid As SHSTOCKICONID, _
 Optional ByVal bLargeIcon As Boolean = False) As Long

  Dim ShIconInfo As SHSTOCKICONINFO
  Dim lRet As Long
  
  ShIconInfo.cbSize = LenB(ShIconInfo)
  
  If bLargeIcon Then
    lRet = SHGetStockIconInfo(siid, SHGSI_ICON Or SHGSI_LARGEICON, ShIconInfo)
  Else
    lRet = SHGetStockIconInfo(siid, SHGSI_ICON Or SHGSI_SMALLICON, ShIconInfo)
  End If
  
  If lRet = S_OK Then GetStockIcon = ShIconInfo.hIcon

End Function

Потом можно напр. конвертануть в альфа-битмап и запихнуть в меню.
Хотя на "классическом" стиле проще рисовать через коллбэки:

Public Function HBITMAP_fromStockIcon(ByVal siid As SHSTOCKICONID) As Long
  'возвращает alpha-blended bitmap соотв. системной иконке из SHSTOCKICONID - для меню на Vista и выше
  Dim lngIcon As Long
  Dim hdc As Long
  Dim hMemDC As Long
  Dim hMemBmp As Long
  Dim hResultBmp As Long
  Dim hOrgBMP As Long
  Dim bmiDst As BITMAPINFO2
  Dim pBits As Long
  
  lngIcon = GetStockIcon(siid, False)
  hdc = GetDC(0)
  hMemDC = CreateCompatibleDC(hdc)
  
  With bmiDst.bmiHeader
    .biSize = LenB(bmiDst.bmiHeader)
    .biWidth = 16
    .biHeight = 16
    .biPlanes = 1
    .biBitCount = 32
    .biCompression = BI_RGB
  End With
  hMemBmp = CreateDIBSection(0, bmiDst, DIB_RGB_COLORS, pBits, 0, 0)
  
  'hMemBmp = CreateCompatibleBitmap(hdc, 16, 16)
  hResultBmp = 0
  hOrgBMP = SelectObject(hMemDC, hMemBmp)
  DrawIconEx hMemDC, 0, 0, lngIcon, 16, 16, 0, 0, DI_NORMAL
  hResultBmp = hMemBmp
  hMemBmp = 0
  SelectObject hMemDC, hOrgBMP
  DeleteDC hMemDC
  ReleaseDC 0, hdc
  DestroyIcon lngIcon
  HBITMAP_fromStockIcon = hResultBmp
End Function

  h_MENU_Bitmap(0) = HBITMAP_fromStockIcon(SIID_SHIELD)
  h_MENU_Bitmap(1) = HBITMAP_fromStockIcon(SIID_FOLDER)
  h_MENU_Bitmap(2) = HBITMAP_fromStockIcon(SIID_HELP)
  
  Dim hMenu As Long
  hMenu = GetSubMenu(GetMenu(Me.hwnd), 0)
  
  SetMenuItemBitmaps hMenu, 0, MF_BYPOSITION, h_MENU_Bitmap(0), h_MENU_Bitmap(0) 'Security shield. Use for UAC prompts only.
  SetMenuItemBitmaps hMenu, 2, MF_BYPOSITION, h_MENU_Bitmap(1), h_MENU_Bitmap(1)
  SetMenuItemBitmaps hMenu, 3, MF_BYPOSITION, h_MENU_Bitmap(2), h_MENU_Bitmap(2)

А вот интересно, чтоб наляпать значок администратора на кнопку, достаточно одной команды:

SendMessage CommandActivate.hwnd, BCM_SETSHIELD, 0&, ByVal 1&

Решение задачи: «Как вытягивать системные иконки типа SIID_SHIELD и вставлять в меню.»

textual
                            Листинг программы 
                        

                            Public Sub SetStockIcon( _
      ByVal hwnd As Long, _
      ByVal siid As SHSTOCKICONID, _
      Optional ByVal bSetAsAppIcon As Boolean = True, _
      Optional ByRef hIconLarge As Long, _
      Optional ByRef hIconSmall As Long)
        
  'устаналивает иконку формы (и приложения) соотв. системной иконке из SHSTOCKICONID
  '16x16 + 32х32 для отображении в Alt+TAB на >=Виста, а также на панели задач >=Win7(?)
  'если по честному, то хэндлы hMeIconLarge и hMeIconSmall надо возвращать, чтоб их потом удалить
  'удалять хэндлы сразу нельзя, пока иконки используются
        
  Dim lhWndTop As Long
  Dim lhWnd As Long
      
  If (bSetAsAppIcon) Then
    ' Find VB's hidden parent window:
    lhWnd = hwnd
    lhWndTop = lhWnd
    Do While Not (lhWnd = 0)
      lhWnd = GetWindow(lhWnd, GW_OWNER)
      If Not (lhWnd = 0) Then
        lhWndTop = lhWnd
      End If
    Loop
  End If
   
  'to retrieve the large version of the icon,
  'as specified by the SM_CXICON and SM_CYICON system metrics
  hIconLarge = GetStockIcon(siid, True)
  If (bSetAsAppIcon) Then
    SendMessageLong lhWndTop, WM_SETICON, ICON_BIG, hIconLarge
  End If
  SendMessageLong hwnd, WM_SETICON, ICON_BIG, hIconLarge
  
  'to retrieve the small version of the icon,
  'as specified by the SM_CXSMICON and SM_CYSMICON system metrics
  hIconSmall = GetStockIcon(siid, False)
  If (bSetAsAppIcon) Then
    SendMessageLong lhWndTop, WM_SETICON, ICON_SMALL, hIconSmall
  End If
  SendMessageLong hwnd, WM_SETICON, ICON_SMALL, hIconSmall
  
  
End Sub

                        