*!* 作者：十豆三
*!* 日期：2010-06-10
*!* vfp版本：vfp9.0(SP2 7423)
*!* 操作系统：Windows XP(SP3)
*!* 说明：部分代码为转帖内容(感谢原作者)，本人只对_GetFile过程等处稍加修改并加入生成图标文件模块。可惜由于所用 API 的限制生成的图标只能是16色的。
*!* 由于本方法提取的图标不够完美，针对此问题 dkfdtf 版主给出了完美的解决方案，请参考：
*!* dkfdtf 版主的：提取可执行文件中图标
Public frm
frm=Createobject ("Tform")
frm.Visible = .T.
Define Class Tform As Form
Width=650
Height=400
BackColor=Rgb(200,255,200)
AutoCenter=.T.
Caption="WIN API-VFP提取文件中(图标资源)的图标(exe/dll/cpl/scr/ico/icl/cur/ocx)"
Add Object lbl As Label With Caption="文件:",Left=15,Top=15,BackStyle=0
Add Object txt As TextBox With Left=50,Top=8,Height=24,Width=450,Anchor=10
Add Object cmdFile As CommandButton With Caption="选择文件",Top=8,Left=505,Width=80,Height=24,Anchor=8
Add Object cmd As CommandButton With Caption="刷新",Width=80,Height=24,Left=300,Top=360,Default=.T.,Anchor=260
Add Object MyImage As Image With Width=64,Height=64,Left=600,Top=05,BackStyle=0,Visible=.F.,Anchor=8
Add Object MyList As ListBox With Width=80,Height=350,Left=560,Top=40,Anchor=13
Add Object MyShape As Shape With Width=Thisform.Width,Height=Thisform.Height,Left=0,Top=0,Visible=.F.,Anchor=15
Procedure Load
Set Safety Off
This.Decl
If !Directory('c:\icon_tmp')
Md 'c:\icon_tmp'
Endif
Endproc
Procedure Init
This.txt.Value=This.getVFPmodule()
This.cmd.SetFocus
This.cmd.Click
Endproc
Procedure MyList.InteractiveChange
lcListValue=This.ListItem(This.ListItemId,2)
If File(lcListValue)
Thisform.MyImage.Picture=lcListValue
Thisform.MyImage.Visible=.T.
Else
Thisform.MyImage.Visible=.F.
Endif
Endproc
Procedure drawIcons
This.MyShape.Visible=.T.
This.MyShape.Visible=.F.
Set Cursor Off
Inkey(0.1,'H')
Set Cursor On
Local lcExe,hApp,lnIndex,hIcon,X,Y,dX,dY
lcExe=Alltrim(This.txt.Value)
If Not File(lcExe)
Wait Window "文件 "+lcExe+" 不存在" Nowait
Endif
hApp=GetModuleHandle(0)
Store 40 TodX,dY
Y=56
X=dX
lnIndex=0
Do While .T.
hIcon=ExtractIcon(hApp,lcExe,lnIndex)
If hIcon=0
Exit
Endif
This._draw(hIcon,X,Y)
lnIndex=lnIndex+1
This.hIcon2Object(hIcon,lnIndex)
=DestroyIcon(hIcon)
X=X+dX
If X>This.Width-80-dX*2
X=dX
Y=Y+dY
Endif
Enddo
Endproc
Protected Procedure _draw(hIcon,X,Y)
Local HWnd,hdc
HWnd=GetFocus()
hdc=GetDC(HWnd) && this form
DrawIcon(hdc,X,Y,hIcon)
=ReleaseDC(HWnd,hdc)
Endproc
Procedure selectFile
Local lcFile
lcFile=This._GetFile()
If Len(lcFile)<>0
This.txt.Value=lcFile
This.cmd.Click
Endif
Endproc
Protected Function _GetFile
Local lcResult,lcPath, lcStoredPath
lcPath=Sys(5)+Sys(2003)
lcStoredPath=Fullpath(This.txt.Value)
lcStoredPath=Substr(lcStoredPath,1,Rat(Chr(92),lcStoredPath)-1)
Set Default To (lcStoredPath)
*lcResult=Getfile("exe,dll,cpl,scr,ico,icl,cur,ocx:exe,dll,cpl,scr,ico,icl,cur,ocx;可执行文件(*.exe):exe;动态链接库(*.dll):dll;控制面板扩展项(*.cpl):cpl;屏幕保护程序(*.scr):scr;图标文件(*.ico):ico;图标文件库(*.icl):icl;光标文件(*.cur):cur;控件(*.ocx):ocx","","",0,"请选择exe/dll/cpl/scr/ico/icl/cur/ocx文件")
lcResult=Getfile("exe,dll,cpl,scr,ico,icl,cur,ocx:exe,dll,cpl,scr,ico,icl,cur,ocx;*.exe:exe;*.dll:dll;*.cpl:cpl;*.scr:scr;*.ico:ico;*.icl:icl;*.cur:cur;*.ocx:ocx","","",0,"请选择exe/dll/cpl/scr/ico/icl/cur/ocx文件")
If Inlist(Justext(lcResult),"EXE","DLL","CPL","SCR","ICO","ICL","CUR","OCX")
Set Default To (lcPath)
Return Lower(lcResult)
Else
Set Default To (lcPath)
Return ""
Endif
Endfunc
Procedure Decl
Declare IntegerGetFocus Inuser32
Declare Integer GetDCIn user32Integer HWnd
Declare Integer GetModuleHandle In kernel32 Integer lpModuleName
Declare Integer ReleaseDC In user32 Integer HWnd,Integerhdc
Declare Integer LoadIcon In user32 Integer hInstance,IntegerlpIconName
Declare Integer ExtractIcon In shell32 IntegerhInst,StringlpszExeFileName,IntegerlpiIcon
Declare Short DrawIcon In user32 Integer hDC,Integer X,Integer Y,Integer hIcon
Declare Integer GetModuleFileName In kernel32 IntegerhModule,String@lpFilename,IntegernSize
Declare Short DestroyIcon In user32 Integer hIcon
Declare Integer OleCreatePictureIndirect In oleaut32 String@lpPictDesc,String@riid,LongfOwn,Object@lplpvObj
Endproc
Protected Function getVFPmodule
Local lpFilename
lpFilename=Space(250)
lnLen=GetModuleFileName(0,@lpFilename,Len(lpFilename))
Return Left (lpFilename,lnLen)
Endfunc
Procedure hIcon2Object(lhIcon,lnIcoNum)
#Define PICTYPE_ICON 3
#Define GUID_Icon 0h8109F87B32BF1A108BBB00AA00300CAB && 0h0004020000000000C000000000000046
Local lcPictDesc,lqGuid,loIconObj
lcPictDesc=BinToC(16,"4RS")+; && Size of Structure
BinToC(PICTYPE_ICON,"4RS")+; && Type of Image
BinToC(lhIcon,"4RS")+; && Image Handle
BinToC(0,"4RS")
lqGuid=GUID_Icon
loIconObj=0
OleCreatePictureIndirect(@lcPictDesc,@lqGuid,1,@loIconObj)
If Vartype(loIconObj)='O'
lcIconFile="c:\icon_tmp\"+Transform(lnIcoNum)+".ico"&& 生成 ico 文件到 c:\icon_tmp\,但是生成的 .ico 文件是16色
* 现在的 Exe 所带图标一般都是标准图标组，就是16x16、32x32、48x48三组，每组又分为16色、256色、32位色三种。
* 用这种方法是有局限性的，就是不能指定到底要提取哪个色深的图标。完美解决方案：请参考 dkfdtf 版主的博客：提取可执行文件中图标
If SavePicture(loIconObj,lcIconFile)
This.MyList.AddListItem(Transform(lnIcoNum)+".ico",lnIcoNum,1)
This.MyList.AddListItem(lcIconFile,lnIcoNum,2)
Endif
Endif
Endfunc
Procedure cmd.Click
Clear Resources
Thisform.MyList.Clear
Erase "c:\icon_tmp\*.*"
Thisform.drawIcons
Thisform.MyList.ListItemId=1
Thisform.MyList.InteractiveChange()
Endproc
Procedure cmdFile.Click
Thisform.selectFile
Endproc
Enddefine
