Have icon, need bmp

[Per Fimmeland]

Hi,

When You right-click Explorer's ListView You get a pop-up, select "Send To" and
You get a list of "recipients" with a icon to the left of the name.

I want to make some similar, but having two problems
- get the "default" icon for a exe
- convert a icon to a bmp to be used with the SetMenuItemBitmaps API

Anyone got any sample code of how to accomplish this ??

TIA
-p


------------------

[Semen Matusovski]

Per --

1. As I know, typically to extract icons is used ExtractIcon(Ex).
Could be another way - LoadLibrary (exe-file) and LoadIcon ("PROGRAM").

Third variant - to use Shell functions.

  #Compile Exe
  #Dim All
  #Register None
  #Include "win32Api.inc"

  $FileNm = "G:\WinNt\NotePad.exe" ' <-------- Change

  Declare Function CoInitialize Lib "ole32.dll" Alias "CoInitialize"( ByVal pvReserved As Dword ) As Dword
  Declare Sub CoUninitialize Lib "ole32.dll" Alias "CoUninitialize"

  Declare Function ImageList_Draw Lib "comctl32.dll" Alias "ImageList_Draw" _
      (ByVal himl As Long, ByVal i As Long, _
      ByVal hDCDest As Long, ByVal x As Dword, ByVal y As Long, ByVal flags As Long) As Long

  %ILD_TRANSPARENT = 1&

  CallBack Function DlgProc

     Select Case CbMsg
        Case %WM_PAINT
           Dim hImg1 As Long, hImg2 As Long, ShFileInfo1 As SHFILEINFO, ShFileInfo2 As SHFILEINFO, hDC As Long

           hDC = GetDC(CbHndl)
           hImg1 = SHGetFileInfo ($FileNm, 0&, ShFileInfo1, SizeOf(ShFileInfo1), _
                                 %SHGFI_TYPENAME Or %SHGFI_SHELLICONSIZE Or %SHGFI_SYSICONINDEX Or _
                                 %SHGFI_DISPLAYNAME Or %SHGFI_EXETYPE Or %SHGFI_SMALLICON)

           ImageList_Draw hImg1, ShFileInfo1.iIcon, hDC, 10, 10, %ILD_TRANSPARENT

           hImg2 = SHGetFileInfo ($FileNm, 0&, ShFileInfo2, SizeOf(ShFileInfo2), _
                                 %SHGFI_TYPENAME Or %SHGFI_SHELLICONSIZE Or %SHGFI_SYSICONINDEX Or _
                                 %SHGFI_DISPLAYNAME Or %SHGFI_EXETYPE Or %SHGFI_LARGEICON)

           ImageList_Draw hImg2, ShFileInfo2.iIcon, hDC, 50, 50, %ILD_TRANSPARENT
           ReleaseDC CbHndl, hDC

           If ShFileInfo1.hIcon Then DestroyIcon ShFileInfo1.hIcon
           If ShFileInfo2.hIcon Then DestroyIcon ShFileInfo2.hIcon

    End Select
  End Function


  Function PbMain
      Local hDlg As Long

      CoInitialize 0

      Dialog New 0, "Test", , , 100, 100, %WS_CAPTION Or %WS_SYSMENU To hDlg
      Dialog Show Modal hDlg Call DlgProc

      CoUninitialize
  End Function

2. About one month ago I posted an utility, which creates a bitmap file for Toolbar.
Like source could be used icons too.

Step 1. DrawIcon(Ex).
Step 2. hDC -> hBmp or Bitmap file (I posted many variants).

------------------
E-MAIL: [email protected]

[This message has been edited by Semen Matusovski (edited October 29, 2000).]

[Per Fimmeland]

Semen,
Your "Third variant - to use Shell functions" works great

I still have problem with displaying a small icon/bmp on a popup menu

'
'This code results in icons correctly drawn on the dialog itself, but on the menu only black squares appears.
'used FACE1..5.ico from "pbdll6\samples\Tray" as 
'
'I'm on real thin ice here, not quite sure of what i'm doin'


Sub rPop (Byval hDlg as Long)
 Dim p     AS POINTAPI
 Dim hPopup AS LONG
 Dim i&, xx&, yy&, j&
 Dim wStyle&
 Dim fName$
 Dim iHnd&
 Dim hBmp&
 Dim hdc&, hdcTarget&
 
	MENU NEW POPUP to hPopup

	wStyle = %MF_ENABLED

	fName = DIR$("*.*")
	While Len(fName) > 0

		Incr i
		MENU ADD STRING, hPopup, fName, i, wStyle ', Call popBack ' doesn't work...

		iHnd = ExtractIcon(hDlg, BYVAL STRPTR(fName), -1)
		If iHnd > 0 Then
			
			xx = 16
			yy = 16

			fName = "FACE" & Trim$(Str$(j)) & ".ico"
         iHnd = LoadImage(ByVal 0&, BYVAL STRPTR(fName), %IMAGE_ICON, xx, yy, %LR_LOADFROMFILE)   

			hdcTarget = GetDC(hDlg) 
			' creates nothing on popUp , hdcTarget = GetDC(hPopUp)
			' creates a Icon on dlg when  hdcTarget = GetDC(hDlg)

			Call SaveDC (hdcTarget)										' *ReleaseDC 
			hdc = CreateCompatibleDC(hdcTarget)						' *DeleteDC
			
			Call DrawIconEx (hdcTarget, 0, (j-1) * 16, iHnd ,16, 16, 0, 0, %DI_NORMAL)

			SelectObject hDC, hdcTarget 'hBmp
'			hBmp = CreateCompatibleBitmap(hdcTarget, xx, yy)	' *DeleteObject
			hBmp = CreateCompatibleBitmap(hdc, xx, yy)	' *DeleteObject

			Call BitBlt (hBmp, 0, 0, xx, yy, hdcTarget, 0,0,%SRCCOPY)

			SetMenuItemBitmaps hPopup, i, %MF_BYCOMMAND, hBmp, hBmp
			'*	When the menu is destroyed, any bitmaps are not destroyed; 
			'	it is up to the application to destroy them. - I wonder how...

			' *This must? be done, but can't be done here, if done, nothing appears on menu
			'DeleteObject hBmp
			
		   DeleteDC hdc

			   ' -1 restores the most recently saved DC
		   RestoreDC hdcTarget, -1
   		ReleaseDC %NULL, hdcTarget

			DestroyIcon iHnd

			Incr j

		End If
		

		fName = Dir$
	Wend
	
   SetForegroundWindow hDlg
   GetCursorPos p
   TrackPopupMenu hPopup, 0, p.x, p.y, 0, hDlg, ByVal %NULL
   
   DestroyMenu hPopUp

End Sub

-p

------------------

[Semen Matusovski]

Per --
I never used SetMenuItemBitmaps.
But I made own-drawn menu, incl. popup. It's enough easy.

Some days ago I posted in this forum a fragment, based on MSDN.
It's base: you have hDC and can draw what you want.
At the same time Borje in Source code posted more detail variant with bitmaps.

------------------
E-MAIL: [email protected]

[Per Fimmeland]

semen,
i have never used setmenuitembitmaps myself before trying now.
as mention earlier the "sub rpop" only produces black squares in front of
the text on the menu.
if you care to test it, just cut'n paste it into your samle code, and add

 case %wm_rbuttondown 
    call rpop(cbhndl)

to the "callback function dlgproc"

maybe own-drawn menus are easy, but..., everything's easy when you know how to do it....

is borje's code is the one in http://www.powerbasic.com/support/pb...ad.php?t=23289
i have tested it (downloaded complete sample from his site) but it doesn't show up
any graphics on my w2000.

-p



------------------

[Semen Matusovski]

Per --
In fragment below don't forget to change file-pathes.

[This message has been edited by Semen Matusovski (edited October 30, 2000).]

[Semen Matusovski]

I assembled some fragments w/o real test.
On my PC (Win2000) it works.

   #Compile Exe
   #Dim All
   #Register None
   #Include "Win32Api.Inc"
   #Include "CommCtrl.Inc"
  
   Declare Function CoInitialize Lib "ole32.dll" Alias "CoInitialize"( ByVal pvReserved As Dword ) As Dword
   Declare Sub CoUninitialize Lib "ole32.dll" Alias "CoUninitialize"

   Type MYITEM
      hfont     As Long
      SizeA     As SizeL
      psz       As Asciiz * 255
      FileName  As Asciiz * %MAX_PATH
   End Type

   Function GetAFont(fnFont As Long) As Long

      Local lf As LOGFONT
      Local sFontName As String
      GetObject GetStockObject(%ANSI_VAR_FONT), SizeOf(lf), ByVal VarPtr(lf)
      If (fnFont = 1) Then
         lf.lfHeight = -14
         lf.lfWeight = %FW_BOLD
         lf.lfFaceName = "Times New Roman"
      Else
         lf.lfWeight = %FW_NORMAL
      End If
      lf.lfItalic = (fnFont = 2)
      lf.lfUnderline = (fnFont = 3)
      lf.lfCharset = %RUSSIAN_CHARSET
      Function = CreateFontIndirect(lf)

   End Function
  
   CallBack Function DlgProc
      %IDM_TEST = 100
      %nIDM = 3

      Static hPopup As Long
      Dim pMyItem As MYITEM Ptr
      Dim MyItem(1 To %nIDM) As Static MYITEM

      Local i As Long

      Local lpmis As MEASUREITEMSTRUCT Ptr
      Local lpdis As DRAWITEMSTRUCT Ptr
      Local hdc As Long
      Local hfontOld As Long
  
      Select Case CbMsg
         Case %WM_CONTEXTMENU
            If IsFalse(hPopup) Then
               Menu New Popup To hPopup
               For i = 1 To %nIDM
                  Menu Add String, hPopup, "", %IDM_TEST + i, %MF_ENABLED
                  ModifyMenu hPopup, 100 + i, %MF_BYCOMMAND Or %MF_OWNERDRAW, 100 + i, ByVal VarPtr(myitem(i))
                  MyItem(i).hfont = GetAFont(i)
                  Select Case i
                     Case 1: MyItem(i).psz = "Notepad"
                             MyItem(i).FileName = "G:\WinNt\Notepad.Exe" ' <--- Change
                     Case 2: MyItem(i).psz = "Explorer"
                             MyItem(i).FileName = "G:\WinNt\Explorer.Exe" ' <--- Change
                     Case 3: MyItem(i).psz = "WordPad"
                             MyItem(i).FileName = "G:\Program Files\Windows Nt\Accessories\WordPad.Exe" ' <--- Change
                  End Select
               Next
            End If
            
            Dim pt As POINTAPI
            GetCursorPos pt
            TrackPopupMenu hPopup, %TPM_LEFTALIGN Or %TPM_RIGHTBUTTON, pt.x, pt.y, ByVal 0, CbHndl, ByVal 0
            
         Case %WM_DESTROY
            For i = 1 To %nIDM: DeleteObject MyItem(i).hfont: Next

        Case %WM_MEASUREITEM
            hdc = GetDC(CbHndl)
            lpmis = CbLparam
            pmyitem = @lpmis.itemData
            hfontOld = SelectObject(hdc, @pmyitem.hfont)
            GetTextExtentPoint32 hdc, @pmyitem.psz, Len(@pmyitem.psz), @pmyitem.SizeA
            @lpmis.itemWidth = 4 + GetSystemMetrics(%SM_CYSMICON) + @pmyitem.sizeA.cx
            @lpmis.itemHeight = Max(GetSystemMetrics(%SM_CYSMICON), @pmyitem.sizeA.cy)
            SelectObject hdc, hfontOld
            ReleaseDC CbHndl, hdc
            Function = %TRUE: Exit Function

        Case %WM_DRAWITEM
            lpdis = CbLparam
            pmyitem = @lpdis.itemData
            If (@lpdis.itemState And %ODS_SELECTED) Then
               SetTextColor @lpdis.hDC, GetSysColor(%COLOR_HIGHLIGHTTEXT)
               SetBkColor @lpdis.hDC, GetSysColor(%COLOR_HIGHLIGHT)
            Else
               SetTextColor @lpdis.hDC, GetSysColor(%COLOR_MENUTEXT)
               SetBkColor @lpdis.hDC, GetSysColor(%COLOR_MENU)
            End If
            hfontOld = SelectObject(@lpdis.hDC, @pmyitem.hfont)

            ExtTextOut @lpdis.hDC, 4 + GetSystemMetrics(%SM_CYSMICON) + @lpdis.rcItem.nleft, _
                @lpdis.rcItem.nTop + (@lpdis.rcItem.nBottom - @lpdis.rcItem.nTop - @pmyitem.sizeA.cy) / 2, %ETO_OPAQUE, _
                @lpdis.rcItem, @pmyitem.psz, Len(@pmyitem.psz), ByVal 0
            
           Dim hImg As Long, ShFileInfo As SHFILEINFO
           hImg = SHGetFileInfo (@pmyItem.FileName, 0&, ShFileInfo, SizeOf(ShFileInfo), _
                                 %SHGFI_TYPENAME Or %SHGFI_SHELLICONSIZE Or %SHGFI_SYSICONINDEX Or _
                                 %SHGFI_DISPLAYNAME Or %SHGFI_EXETYPE Or %SHGFI_SMALLICON)
           ImageList_Draw hImg, ShFileInfo.iIcon, @lpdis.hDC, @lpdis.rcItem.nleft, @lpdis.rcItem.nTop, %ILD_TRANSPARENT
           
           If ShFileInfo.hIcon Then DestroyIcon ShFileInfo.hIcon
           
           SelectObject @lpdis.hDC, hfontOld
           Function = %TRUE: Exit Function

         Case %WM_COMMAND
            Select Case CbCtl
               Case %IDM_TEST + 1 To %IDM_TEST + %nIDM: MsgBox Str$(CbCtl)
            End Select
    End Select
  End Function

  Function PbMain
      Local hDlg As Long
      CoInitialize 0
      Dialog New 0, "Test", , , 100, 100, %WS_CAPTION Or %WS_SYSMENU To hDlg
      Dialog Show Modal hDlg Call DlgProc
      CoUninitialize
  End Function

------------------
E-MAIL: [email protected]

[Per Fimmeland]

Semen,

I've been away from my pc some days, but now I'm back and have
tested Your sample on W2000, NT4 and W98, and it runs perfectly
on all platforms!

Thanks.

-p


------------------