WINAPI-VFP获得EXE、DLL或ICO文件图标.doc

WIN API-VFP获得EXE、DLL或ICO文件图标
[ 275 查看 / 19 回复 ]
返回列表

窗体顶端

· 发送短消息
UID
9805
精华
0
威望
10
金钱
10 元
查看公共资料 搜索帖子
apple_8180

apple_8180

· 组别新手上路
· 性别 保密
· 积分10
· 帖子1174
· 注册时间 2010-03-17
apple_8180 2010-06-29 10:19 |只看楼主 1#
字体大小: t T
*!*    日  期：2010-06-10
*!*    说  明：部分代码为转帖内容(感谢原作者)，本人只对_GetFile过程等处稍加修改并加入生成图标文件模块。可惜由于API的限制生成的图标只能是16色的。
VB code

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或ico文件图标"

    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
    Add Object cmdFile As CommandButton With Caption="选择文件",Top=8,Left=505,Width=80,Height=24
    Add Object cmd As CommandButton With Caption="刷新",Width=80,Height=24,Default=.T.
    Add Object MyImage As Image With Width=64,Height=64,Left=600,Top=05,BackStyle=0,Visible=.F.
    Add Object MyList As ListBox With Width=80,Height=350,Left=560,Top=40

    Procedure Load
        Set Safety Off
        This.Decl
    Endproc

    Procedure Init
        This.txt.Value=This.getVFPmodule()
        This.Resize
        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 Resize
        With This.cmd
            .Left=Int((Thisform.Width-.Width)/2)
            .Top=This.Height-.Height-10
        Endwith
    Endproc

    Procedure drawIcons
        * clear form
        This.Visible=.F.
        This.Visible=.T.
        =Inkey(0.1)        && give a break

        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 To dX,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,*.ico):exe,dll,ico;可执行文件(*.exe):Exe;动态链接库(*.dll):Dll;图标文件(*.ico):Ico","","",0,"请选择exe、dll或ico文件")
        If Inlist(Justext(lcResult),"EXE","DLL","ICO")
            Set Default To (lcPath)
            Return Lower(lcResult)
        Else
            Set Default To (lcPath)
            Return ""
        Endif
    Endfunc

    Procedure Decl
        Declare Integer GetFocus In user32
        Declare Integer GetDC In user32 Integer HWnd
        Declare Integer GetModuleHandle In kernel32 Integer lpModuleName
        Declare Integer ReleaseDC In user32 Integer HWnd,Integer hdc
        Declare Integer LoadIcon In user32 Integer hInstance,Integer lpIconName
        Declare Integer ExtractIcon In shell32 Integer hInst,String lpszExeFileName,Integer lpiIcon
        Declare Short DrawIcon In user32 Integer hDC,Integer X,Integer Y,Integer hIcon
        Declare Integer GetModuleFileName In kernel32 Integer hModule,String @lpFilename,Integer nSize
        Declare Short DestroyIcon In user32 Integer hIcon
        Declare Integer OleCreatePictureIndirect In oleaut32 String @lpPictDesc,String @riid,Long fOwn,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
        BinToCPICTYPE_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:\"+Transform(lnIcoNum)+".ico"        && 生成 ico 文件到 c:\,但是生成的 .ico 文件是16色
            * 现在的 Exe 所带图标一般都是标准图标组，就是16x16、32x32、48x48三组，每组又分为16色、256色、32位色三种。用Windows的API函数是有局限性的，就是不能指定到底要提取哪个色深的图标。
            * 想要提取某一个图标，方法是有的，就是不使用API函数，自己来，但必须了解 PE 结构。
            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
        Thisform.drawIcons
        Thisform.MyList.ListItemId=1
        Thisform.MyList.InteractiveChange()
    Endproc
    Procedure cmdFile.Click
        Thisform.selectFile
    Endproc
Enddefine

窗体底端