Files
comun/utile/Menu/menutool.vc2

2435 lines
74 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

*--------------------------------------------------------------------------------------------------------------------------------------------------------
* (EN) AUTOGENERATED - ATTENTION!! - NOT INTENDED FOR EXECUTION!! USE ONLY FOR MERGING CHANGES AND STORING WITH SCM TOOLS!!
*--------------------------------------------------------------------------------------------------------------------------------------------------------
*< FOXBIN2PRG: Version="1.21" SourceFile="menutool.vcx" CPID="936" /> (Solo para binarios VFP 9 / Only for VFP 9 binaries)
*
*
DEFINE CLASS _menuinfo AS custom && 菜单栏目对象
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
*<DefinedPropArrayMethod>
*p: ccommand && 执行命令
*p: cenabled && Enabled 表达式
*p: ckey && 当前节点 Key
*p: cmessage && 菜单提示信息
*p: cparentkey && 父亲 Key无则为 ""
*p: cpicture && 菜单项图片
*p: ctitle && 菜单标题
*p: ctitle2 && 程序实际使用的 Title
*p: hmenu && 如果是一个子菜单,保存子菜单的句柄
*p: hmsk && 掩码地址
*p: hparent && 父菜单句柄
*p: hpic && 图标地址
*p: lenabled && 保存 Evaluate(clEnabled) 状态
*p: naddress && 菜单栏目的内存地址
*p: nflags && 菜单标记
*p: nheight && 项目高度
*p: nindex && 物理索引项目号
*p: nwidth && 项目宽度
*p: orefmenu && 指向另一个预定义菜单菜单
*</DefinedPropArrayMethod>
*<PropValue>
ccommand =
cenabled =
ckey =
cmessage = .NULL.
cparentkey =
cpicture =
ctitle =
ctitle2 =
hmenu = 0
hmsk = 0
hparent = 0
hpic = 0
lenabled = .F.
naddress = 0
Name = "_menuinfo"
nflags = 0
nheight = 0
nindex = 0
nwidth = 0
orefmenu = .NULL.
Width = 17
*</PropValue>
ENDDEFINE
DEFINE CLASS iconcollection AS custom && 图标句柄收集
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
#INCLUDE "win32api.h"
*<DefinedPropArrayMethod>
*m: declare_dlls
*m: getimage && 返回图形文件在内存中的句柄
*m: loadimage
*m: newimage && 新定义一个图形文件名柄
*</DefinedPropArrayMethod>
*<PropValue>
Name = "iconcollection"
Width = 17
*</PropValue>
PROCEDURE declare_dlls
Declare Long GetFileAttributes In "Kernel32" ;
String lpFileName
Declare Long LoadImage In "User32" ;
Long hInst, String lpszName, Long uType, ;
Long cxDesired, Long cyDesired, Long fuLoad
ENDPROC
PROCEDURE getimage && 返回图形文件在内存中的句柄
LPARAMETERS tcImageFile
Private lnIndex
Local lnIndex
If Not PemStatus(This, "aIconCollection", 5) ;
Or Not PemStatus(This, "nIconCollection", 5)
This.AddProperty("aIconCollection[1, 2]")
This.aIconCollection[1, 1] = "" && 文件名
This.aIconCollection[1, 2] = 0 && 内存句柄
This.AddProperty("nIconCollection", 0)
EndIf
*-- 倒序
For lnIndex = This.nIconCollection To 1 Step -1
If This.aIconCollection[m.lnIndex, 1] == Upper(m.tcImageFile)
Return This.aIconCollection[m.lnIndex, 2]
EndIf
EndFor
Return 0
ENDPROC
PROCEDURE Init
If Not PemStatus(_Screen, This.Class, 5)
This.Declare_Dlls()
_Screen.AddProperty(This.Class, .T.)
EndIf
ENDPROC
PROCEDURE loadimage
LPARAMETERS tcPicture
Private lhImage, lcExt, lcString, llDelete
Local lhImage, lcExt, lcString, llDelete
If Vartype(m.tcPicture) <> "C" ;
Or Empty(m.tcPicture) ;
Or Not File(m.tcPicture)
Return 0
EndIf
*-- 检查文件是否被包含进 EXE 文件中
llDelete = .F.
If GetFileAttributes(m.tcPicture) = -1
lcFileVal = FileToStr(m.tcPicture)
tcPicture = Addbs(Sys(2023)) + JustFname(m.tcPicture)
StrToFile(m.lcFileVal, m.tcPicture)
If GetFileAttributes(m.tcPicture) = -1
Return 0
EndIf
llDelete = .T.
EndIf
lhImage = 0
lcExt = Upper(JustExt(m.tcPicture))
Do Case
Case m.lcExt == "BMP"
lhImage = This.GetImage(m.tcPicture)
If m.lhImage = 0
lhImage = LoadImage(0, m.tcPicture, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
This.NewImage(m.tcPicture, m.lhImage)
EndIf
Case m.lcExt == "MSK"
lhImage = This.GetImage(m.tcPicture)
If m.lhImage = 0
m.lhImage = LoadImage(0, m.tcPicture, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
This.NewImage(m.tcPicture, m.lhImage)
EndIf
Case m.lcExt == "ICO"
lhImage = This.GetImage(m.tcPicture)
If m.lhImage = 0
lhImage = LoadImage(0, m.tcPicture, IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
This.NewImage(m.tcPicture, m.lhImage)
EndIf
Otherwise
*-- 待处理
EndCase
If m.llDelete
Erase (m.tcPicture)
EndIf
Return m.lhImage
ENDPROC
PROCEDURE newimage && 新定义一个图形文件名柄
LPARAMETERS tcImageFile, tnHandle
Private lnIndex
Local lnIndex
If Not PemStatus(This, "aIconCollection", 5) ;
Or Not PemStatus(This, "nIconCollection", 5)
This.AddProperty("aIconCollection[1, 2]")
This.aIconCollection[1, 1] = "" && 文件名
This.aIconCollection[1, 2] = 0 && 内存句柄
This.AddProperty("nIconCollection", 0)
EndIf
If m.tnHandle = 0
Return
EndIf
This.nIconCollection = Max(This.nIconCollection + 1, 1)
Dimension This.aIconCollection[This.nIconCollection, 2]
This.aIconCollection[This.nIconCollection, 1] = Upper(m.tcImageFile)
This.aIconCollection[This.nIconCollection, 2] = m.tnHandle
ENDPROC
ENDDEFINE
DEFINE CLASS popmenu AS custom && 覱键礯3霾说<E99CBE>
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
#INCLUDE "win32api.h"
*<DefinedPropArrayMethod>
*m: about && 1O于盻A<E79BBB>
*m: add && I砑硬说<E7A1AC><EFBFBD>PARAMETERS tcParentKey, tcKey, tcTitle, tcCommand, tcPicture, tvEnabled, tnAddFlag
*m: additem && I砑硬说<E7A1AC><E8AFB4>: tnId, tcCaption, tcCommand, tlEnabled, tnAddFlag. 0x20 换罝, 0x08 Check。
*m: bindevents
*m: b_drawmenuitem
*m: b_measuremenuitem
*m: b_menuchar
*m: callback_proc
*m: clear && 清3<E6B885>楹I框或罝表框縊糭諨的内E荨<45>
*m: createcontext && 创建与指I蛄鞳桓霾说チ<E8AFB4><E38381>
*m: createmenus
*m: declare_dlls
*m: destroymenus && I<>U菜单
*m: drawgradualrect && 指定莖域后覣指定袿色绘制。可选水平或<E5B9B3>1直。
*m: draw_bar && 画侧边Io
*m: draw_image && 画图I<E59BBE>
*m: draw_selected && 绘制选定
*m: draw_separator
*m: draw_text && 画文盻莖
*m: gethalfcolor && E×<C397><E7BCB4>涞陌肷<E9998C><E882B7>
*m: gethwnd && 获E〈翱赺浔<E8B5BA>
*m: get_rect_num && 从 Rect 结11諨返籓E<E7B193><EFBFBD><E680A0>1<EFBFBD><EFBFBD>说O址参E<E58F82><45><EFBFBD>1<EFBFBD>娴降O址参E<E58F82>D。
*m: get_rect_str && 传递 Left, Top, Right, Bottom 四个参E<E58F82><45>祷O RECT 结11样的字符串。
*m: inititems && 3oE蓟_A改緿臝<E7B7BF>
*m: modifymenus && D_改菜单的 Enabled 状I<E78AB6>
*m: newitem && 获E<E88EB7>桓鯝改慷訧<E685B7>
*m: setmessage && 设諥菜单I钭碔珹窱酔_D臝ⅲ<E8879D>诙_参指物A聿说<E881BF>畹腄蚝牛珽盓<E78FBD>1覣最近I砑拥牟说ァ<E8AFB4>
*m: setpicture && 设諥菜单I畹耐计<E88090><E8AEA1>诙_参指物A聿说<E881BF>頓蚝牛珽盓<E78FBD>1覣最近I砑拥牟说ァ<E8AFB4>
*m: show && I訣_菜单在指定的 x,y 護标外E<EFBC8C>1<EFBFBD>粗付ǎ<E4BB98><C78E>诘鼻癊蟊晡恢AI訣_。
*m: showby && 指定表单的<E58D95>3个对I螅<49><E89E85>诟A对I蟮腎路降_3霾说ァ<E8AFB4>
*m: transparentblta && See win32Api TransparentBlt
*p: classlibraryroot && A嘣璄悸穇禔<E7A987>
*p: hmenu && 主菜单的菜单_浔<5F>
*p: lownerdraw && E欠馝1覣自绘菜单E<EFBC8C>1<EFBFBD> .F. 忽略所覦绘制E鬌浴⒉蜤<E29289><EFBFBD><EFBFBD> Windows 菜单。
*p: lselectedenabled && (读D<E8AFBB>) 只对 Enabled = .T. 的菜单I罱oDD绘制选定框
*p: lshareicons && (读定) E欠馝1覣1睮硗急昕猓珽<E78C93>1<EFBFBD>酥滴<E985A5> .T.图标库会被O恢北<E681A2>3郑琌员蹵庵O复读E <45>绱酥滴<E985A5> .F.则为A扛鯡礎<E9AFA1>唇ǖザA图标索O<E7B4A2><EFBFBD>(调E宰碔<E5AEB0>肷栉<E882B7> .F.)
*p: nbarfillcolor1 && E瞪獻<E79EAA>3洳说ゲ啾逜富騉呓ケ銭保<E98AAD>柚AI<41>3渖<33>騉呓ケ涞钠dE忌<45><E5BF8C>
*p: nbarfillcolor2 && E瞪獻<E79EAA>3洳说ゲ啾逜富騉呓ケ銭保<E98AAD>柚AI<41>3渖<33>騉呓ケ涞慕酔o色。
*p: nbarstyle && (读D<E8AFBB>) 侧边A秆鵈健<E9B588>0=蝊,1=E瞪獻<E79EAA>3<EFBFBD>,2=水平1<E5B9B3><31>,3=<3D>1直1<E79BB4><31>
*p: nbarwidth && (读D<E8AFBB>) 侧边A缚矶E
*p: nhwnd && 窗口_浔<5F>
*p: nimageleft && (读D<E8AFBB>) 图标莖域的左边_<E8BEB9>
*p: nitemheight && (读D<E8AFBB>) 最D<E38094>罡叨E当值D∮诘E于 0 E保<45>远_计薬。
*p: nitemwidth && (读D<E8AFBB>) 最D<E38094>羁矶E当此值D∮诘E于 0 E保<45> 自禵计薬。
*p: nmaxlen && 记录最3の谋_的3ざE在内存分配礝址覣到此值。
*p: nmenubackcolor && (读D<E8AFBB>) 设諥菜单<E88F9C>3_吧<5F><E590A7>酥礑∮<E7A491>0E盓<45>低3设諥
*p: nmenuheight && (只读) 主I訣_菜单高禘
*p: nmenuwidth && (只读) 主I訣_菜单宽禘
*p: nreturn && 返籓值方E健<45>0=索O<E7B4A2>,1 = cKey, 3 = A改课谋_, 4=对I<E5AFB9>
*p: nselectedbackcolor && (读D<E8AFBB>) 当前选定I畹谋3_吧<5F><E590A7>酥礑∮<E7A491> 0 E盓<45>低3设諥
*p: nselectedbordercolor && (读D<E8AFBB>) 选定_OD蔚谋呖蛏<E59196><E89B8F>酥礑∮<E7A491> 0 E盓<45>低3设諥
*p: nselectedforecolor && (读D<E8AFBB>) 选定I畹那癬吧<E799AC><E590A7>酥礑∮<E7A491> 0 E盓<45>低3设諥。
*p: nselectedimagestyle && (读D<E8AFBB>) 选定图标的样E<E6A0B7> 0=蝊, 1=<3D>1芼,2=单禔选定
*p: nselectedroundx && (读D<E8AFBB>) 椭圆_OD窝《ǹ虻脑步强矶E
*p: nselectedroundy && (读D<E8AFBB>) 椭圆_OD窝《ǹ虻脑步歉叨E
*p: nselectedstyle && 选諨Io风格 0=标准<E6A087>3_<33>, 1=_OD慰蜓《ǹ<E3808A>,2=椭圆选定框,3=<3D>1芼选定框,4=凹I卵《ǹ<E3808A>
*p: ntextleft && 设諥文盻莖的左边_<E8BEB9>
*p: ntextmargin && 文盻莖内文盻的的薿給值
*p: ocollections && A改孔芗_篒CreateItems E敝窱蚋鞲鯝改俊唇ㄍ<E59487>3珊驣<E78F8A>U。
*p: oitems && 菜单A改考_篒保存各个A改慷訧<E685B7>
*p: oreficons && 指I蛲急闑O糭器
*p: pproc && 給3I指O<E68C87>
*</DefinedPropArrayMethod>
HIDDEN nhwnd,nmaxlen,nmenuheight,nmenuwidth,ocollections,oitems,oreficons,pproc
*<PropValue>
classlibraryroot = ""
Height = 17
hmenu = 0
lownerdraw = .F.
lselectedenabled = .F.
lshareicons = .T.
Name = "popmenu"
nbarfillcolor1 = -1
nbarfillcolor2 = -1
nbarstyle = 0
nbarwidth = 19
nhwnd = 0
nimageleft = 0
nitemheight = 0
nitemwidth = 0
nmaxlen = 256
nmenubackcolor = -1
nmenuheight = 0
nmenuwidth = 0
nreturn = 0
nselectedbackcolor = -1
nselectedbordercolor = -1
nselectedforecolor = -1
nselectedimagestyle = 0
nselectedroundx = 12
nselectedroundy = 12
nselectedstyle = 0
ntextleft = 20
ntextmargin = 2
ocollections = 指I蚋鞲霾说ゼ_篒
oitems =
oreficons = .NULL.
pproc = 0
Width = 17
*</PropValue>
PROCEDURE about && 1O于盻A<E79BBB>
**********************************************
***
*** Popup Menu Class
*** Version
***
*** Author by: 施凌峰
*** Create date: 2008.05.29
*** Last update: 2008.06.04
***
**********************************************
***
*** 如果它确实对您有所帮助,并且你也非常喜欢,您可以通过网上汇款略表您的心意,让我们在辛劳制作中得到欣慰, 谢谢。
***
*** 银行账号
*** 中国工商银行: 9558 8014 0810 5404 077
*** 中国建设银行: 4367 4218 3350 0044 031
*** 开户人:施凌峰
***
*** 赞助金额不限,只作对我们努力的认可。
***
*** 我们的网址http://xykjsoft.blog.163.com
***
***
*** 测试环境Windows 2000、Windows XP
*** 开发语言Vfp9 SP2
***
ENDPROC
PROCEDURE add && I砑硬说<E7A1AC><EFBFBD>PARAMETERS tcParentKey, tcKey, tcTitle, tcCommand, tcPicture, tvEnabled, tnAddFlag
LPARAMETERS tcParentKey, tcKey, tcTitle, tcCommand, tcPicture, tvEnabled, tnAddFlag
*-- tvParentKey 父亲 Key
*-- tcKey 菜单 Id
*-- tcCaption 菜单标题
*-- tcCommand 菜单结果,执行命令串
*-- tvEnabled 菜单 Enalbed 状态,可以是逻辑立即值或者逻辑型表达式
*-- tnAddFlag 用户添加的自定义 Id
*!* 添加一个菜单项, tnAddFlag = 0x00 标准菜单项0x20 = 换列菜单项, 0x08 = Check。
Private loItem, lcParentKey, lcKey, loParent
Local loItem, lcParentKey, lcKey, loParent
loItem = This.NewItem()
If Not VarType(m.tcParentKey) = "C"
MessageBox("请指定父栏目 Key如不需要请使用空字符串。", 16, "PopMenu.Add")
Return m.loItem
EndIf
If Not VarType(m.tcKey) = "C"
MessageBox("请指定新栏目 Key如不需要请使用空字符串。", 16, "PopMenu.Add")
Return m.loItem
EndIf
lcParentKey = Alltrim(m.tcParentKey)
lcKey = Iif(Empty(m.tcKey), Sys(2015), Alltrim(m.tcKey))
If This.oItems.GetKey(m.lcKey) > 0
MessageBox("指定的栏目 Key 己经存在,请为栏目指定不同 Key。", 16, "PopMenu.Add")
Return m.loItem
EndIf
If Not Empty(m.tcParentKey) ;
And Not This.oItems.GetKey(m.tcParentKey) > 0
MessageBox("指定的父栏目 Key 不存在,请检查父栏目的 Key 值。", 16, "PopMenu.Add")
Return m.loItem
EndIf
*-- 加入集合
This.oItems.Add(m.loItem, m.lcKey)
loItem.cKey = m.lcKey
loItem.cParentKey = m.lcParentKey
loItem.nIndex = This.oItems.Count
loItem.cTitle = Transform(m.tcTitle)
loItem.cCommand = Iif(Vartype(m.tcCommand) = "C", m.tcCommand, "")
loItem.cPicture = Iif(Vartype(m.tcPicture) = "C", m.tcPicture, "")
loItem.cEnabled = Iif(PCount() >= 6, Transform(m.tvEnabled), "")
loItem.nFlags = Iif(Vartype(m.tnAddFlag) = "N", m.tnAddFlag, 0)
loItem.nWidth = This.nItemWidth
loItem.nHeight = This.nItemHeight
If Not Empty(m.lcParentKey)
loParent = This.oItems.Item(This.oItems.GetKey(m.lcParentKey))
loParent.nFlags = BitOr(loParent.nFlags, MF_POPUP)
EndIf
*-- 数据有发生变化,清除信息
This.nMenuWidth = 0
This.nMenuHeight = 0
This.DestroyMenus()
Return m.loItem
ENDPROC
PROCEDURE additem && I砑硬说<E7A1AC><E8AFB4>: tnId, tcCaption, tcCommand, tlEnabled, tnAddFlag. 0x20 换罝, 0x08 Check。
LPARAMETERS tcCaption, tcCommand, tvEnabled, tnAddFlag
Return This.Add("", "", m.tcCaption, m.tcCommand, "", Iif(PCount()>=3, m.tvEnabled, ""), m.tnAddFlag)
ENDPROC
HIDDEN PROCEDURE bindevents
Lparameters tlBindevent
If This.pProc = 0
This.pProc = GetWindowLong(This.nHwnd, GWL_WNDPROC)
EndIf
If m.tlBindevent = .T.
BindEvent(This.nHwnd, WM_MEASUREITEM, This, "CallBack_Proc")
BindEvent(This.nHwnd, WM_DRAWITEM, This, "CallBack_Proc")
BindEvent(This.nHwnd, WM_MENUCHAR, This, "CallBack_Proc")
Else
UnBindEvent(This.nHwnd, WM_MENUCHAR)
UnBindEvent(This.nHwnd, WM_MEASUREITEM)
UnBindEvent(This.nHwnd, WM_DRAWITEM)
EndIf
ENDPROC
HIDDEN PROCEDURE b_drawmenuitem
LPARAMETERS tplParam
** tplParam = pointer to DrawItemStruct
Private lhDestDC, lhOldDC, lhDC, lpItem, lnItemState, lnItemId, loItem
Private lnRectLeft, lnRectTop, lnRectRight, lnRectBottom
Private lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom, lnColor
Private lnBmpLeft, lnBmpTop, lnBmpRight, lnBmpBottom
Private lcRect, lhTmp, lhBrush, llSelect, llEnabled, lcTitle
Local lhDestDC, lhOldDC, lhDC, lpItem, lnItemState, lnItemId, loItem
Local lnRectLeft, lnRectTop, lnRectRight, lnRectBottom
Local lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom, lnColor
Local lnBmpLeft, lnBmpTop, lnBmpRight, lnBmpBottom
Local lcRect, lhTmp, lhBrush, llSelect, llEnabled, lcTitle
Store 0 to lpItem, lhDC, lnItemState, lnItemId
*-- 取回结构信息
CopyMem2NumA(@m.lpItem, m.tplParam + DWORD_SIZE * 11, DWORD_SIZE) && PopItem Data
CopyMem2NumA(@m.lnItemState, m.tplParam + DWORD_SIZE * 4, DWORD_SIZE) && PopItem State
CopyMem2NumA(@m.lhDestDC, m.tplParam + DWORD_SIZE * 6, DWORD_SIZE) && PopItem hDC
*-- 取回集合下标
CopyMem2NumA(@m.lnItemId, m.lpItem + This.nMaxLen, DWORD_SIZE)
If Not Between(m.lnItemId, 1, This.oCollections.Count)
Return
EndIf
loItem = This.oCollections.Item(m.lnItemId)
lcTitle = loItem.cTitle2
*-- 取绘图区域结构
Store 0 To lnRectLeft, lnRectTop, lnRectRight, lnRectBottom
lcRect = Replicate(Chr(0), DWORD_SIZE * 4)
CopyMem2StrA(@m.lcRect, m.tplParam + DWORD_SIZE * 7, DWORD_SIZE * 4)
This.Get_Rect_Num(m.lcRect, @m.lnRectLeft, @m.lnRectTop, @m.lnRectRight, @m.lnRectBottom)
llEnabled = BitAnd(m.lnItemState, ODS_DISABLED ) = 0
llSelected = BitAnd(m.lnItemState, ODS_SELECTED) <> 0
*-- 图标结构
lnBmpLeft = m.lnRectLeft + This.nImageLeft
lnBmpTop = m.lnRectTop
lnBmpRight = m.lnBmpLeft + (m.lnRectBottom - lnRectTop) && 高度或者侧边栏的宽度
lnBmpBottom = m.lnRectBottom
*-- 文字结构
lnTxtLeft = m.lnRectLeft + This.nTextLeft
lnTxtTop = m.lnRectTop
lnTxtRight = m.lnRectRight
lnTxtBottom = m.lnRectBottom
*============ 结束准备
*============ 步骤 1/3绘制图形
*--
*-- 创建兼容设备避免闪烁, vfp 实在太慢太慢了
*--
lhTmp = CreateCompatibleBitmap(m.lhDestDC, m.lnRectRight, m.lnRectBottom)
lhDC = CreateCompatibleDC(m.lhDestDC)
lhOldDC = SelectObject(m.lhDC, m.lhTmp)
DeleteObject(m.lhTmp)
BitBlt(m.lhDC, m.lnRectLeft, m.lnRectTop, m.lnRectRight, m.lnRectBottom, ;
m.lhDestDC, m.lnRectLeft, m.lnRectTop, SRCCOPY)
*-- 清空重画菜单背景
SetBkMode(m.lhDC, TRANSPARENT)
If This.nMenuBackColor < 0
lhBrush = CreateSolidBrush(GetSysColor(COLOR_MENU))
Else
lhBrush = CreateSolidBrush(This.nMenuBackColor)
EndIf
FillRect(m.lhDC, m.lcRect, m.lhBrush)
DeleteObject(m.lhBrush)
*-- 先画菜单项分隔条,避免破坏侧边栏
If Empty(m.lcTitle)
This.Draw_Separator(m.lhDC, m.lnRectLeft, m.lnRectTop, m.lnRectRight, m.lnRectBottom)
EndIf
*-- 画侧边栏,宽度
If This.nBarStyle > 0
This.Draw_Bar(m.lhDC, m.loItem, m.lnRectLeft, m.lnRectTop, m.lnRectLeft + This.nBarWidth, m.lnRectBottom)
EndIf
*-- 画菜单选定效果
If m.llSelected
This.Draw_Selected(m.lhDC, m.loItem, m.llEnabled, m.lnRectLeft, m.lnRectTop, m.lnRectRight, m.lnRectBottom, m.lnBmpLeft, m.lnTxtLeft)
EndIf
*-- 先画位图,避免因为画文字时设置背景色影响透时着色
If (loItem.hPic <> 0)
This.Draw_Image(m.lhDC, m.loItem, m.llEnabled, m.lnBmpLeft, m.lnBmpTop, m.lnBmpRight, m.lnBmpBottom)
EndIf
*============ 步骤 2/3图像完成绘制拷回主 DC
BitBlt(lhDestDC, lnRectLeft, lnRectTop, lnRectRight, lnRectBottom, ;
lhDC, lnRectLeft, lnRectTop, SRCCOPY)
SelectObject(lhDC, lhOldDC)
DeleteDC(lhDC)
lhDC = lhDestDC
*============ 步骤 3/3绘制文字
*-- 设置透明模式
SetBkMode(lhDC, TRANSPARENT)
*-- 画菜单项内容
If Not Empty(m.lcTitle)
*-- 画鼠标所在项的背影
If m.llSelected
If m.llEnabled
lnColor = Iif(This.nSelectedForeColor = -1, GetSysColor(COLOR_HIGHLIGHTTEXT), This.nSelectedForeColor)
This.Draw_Text(lhDC, m.lcTitle, lnColor, lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom)
Else
If This.lSelectedEnabled = .T.
This.Draw_Text(lhDC, m.lcTitle, GetSysColor(COLOR_HIGHLIGHTTEXT), lnTxtLeft + 1, lnTxtTop + 2, lnTxtRight, lnTxtBottom)
This.Draw_Text(lhDC, m.lcTitle, GetSysColor(COLOR_GRAYTEXT), lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom)
Else
This.Draw_Text(lhDC, m.lcTitle, GetSysColor(COLOR_GRAYTEXT), lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom)
EndIf
EndIf
Else
*-- 画其他项文字
If m.llEnabled
This.Draw_Text(lhDC, m.lcTitle, GetSysColor(COLOR_MENUTEXT), lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom)
Else
This.Draw_Text(lhDC, m.lcTitle, GetSysColor(COLOR_HIGHLIGHTTEXT), lnTxtLeft + 1, lnTxtTop + 2, lnTxtRight, lnTxtBottom)
This.Draw_Text(lhDC, m.lcTitle, GetSysColor(COLOR_GRAYTEXT), lnTxtLeft, lnTxtTop, lnTxtRight, lnTxtBottom)
EndIf
EndIf
EndIf
If m.llSelected
If Not Empty(loItem.cMessage)
Set Message To loItem.cMessage
Else
Set Message To
EndIf
EndIf
ENDPROC
HIDDEN PROCEDURE b_measuremenuitem
LPARAMETERS thWnd, tplParam
** tplParam = pointer to MeasureItemStruct
*--
*-- 写入菜单高度与宽度
*--
Private lpItem, lnItemId, loItem
Private lpItem, lnItemId, loItem
Store 0 to lpItem, lnItemId
*-- 取回集合下标
CopyMem2NumA(@m.lpItem, m.tplParam + DWORD_SIZE * 5, DWORD_SIZE)
CopyMem2NumA(@m.lnItemId, m.lpItem + This.nMaxLen, DWORD_SIZE)
If Between(m.lnItemId, 1, This.oCollections.Count)
loItem = This.oCollections.Item(m.lnItemId)
CopyNum2MemA(m.tplParam + (DWORD_SIZE * 3), loItem.nWidth, DWORD_SIZE)
CopyNum2MemA(m.tplParam + (DWORD_SIZE * 4), loItem.nHeight, DWORD_SIZE)
EndIf
ENDPROC
HIDDEN PROCEDURE b_menuchar
ENDPROC
HIDDEN PROCEDURE callback_proc
LParameters thWnd, tnMsg, tpwParam, tplParam
Private lcChr, lhMenu, loMenuItem, lnIndex
Local lcChr, lhMenu, loMenuItem, lnIndex
Do Case
Case (m.tnMsg == WM_MEASUREITEM)
This.b_MeasureMenuItem(m.thWnd, m.tplParam)
Return .T.
Case (m.tnMsg == WM_DRAWITEM)
This.b_DrawMenuItem(m.tplParam)
Return .T.
Case (m.tnMsg == WM_MENUCHAR)
*-- 资料来源
*-- http://msdn.microsoft.com/en-us/library/ms646349(VS.85).aspx
*--
lhMenu = m.tplParam
lcChr = "&" + Upper(Chr(BitAnd(m.tpwParam, 0xFF)))
lnIndex = 0
For Each loMenuItem In This.oCollections
If m.lhMenu = loMenuItem.hParent
If lcChr $ Upper(loMenuItem.cTitle2)
If loMenuItem.lEnabled
Return BitLShift(MNC_EXECUTE, 16 ) + m.lnIndex
Else
Exit For
EndIf
EndIf
m.lnIndex = m.lnIndex + 1
EndIf
EndFor
Return 0
EndCase
Return CallWindowProc(This.pProc, m.thWnd, m.tnMsg, m.twParam, m.tlParam)
ENDPROC
PROCEDURE clear && 清3<E6B885>楹I框或罝表框縊糭諨的内E荨<45>
This.DestroyMenus()
This.oItems = NewObject("Collection")
This.oCollections = NewObject("Collection")
ENDPROC
PROCEDURE createcontext && 创建与指I蛄鞳桓霾说チ<E8AFB4><E38381>
LPARAMETERS tvItem, toPopMenu
Local loItem, lnItem
loItem = NULL
If Vartype(toPopMenu) <> "O" ;
Or Not toPopMenu.Class == This.Class ;
Or toPopMenu = This
Messagebox("创建菜单联系失败!请指定另一个 PopMenu 实例对象!", 16, "PopMenu.CreateContext")
Return .F.
EndIf
Do Case
Case Vartype(tvItem) = "C"
lnItem = This.oItems.GetKey(m.tvItem)
If lnItem > 0
loItem = This.oItems.Item(m.lnItem)
EndIf
Case Vartype(tvItem) = "O" And PemStatus(m.tvItem, "oRefMenu", 5)
loItem = m.tvItem
EndCase
If IsNull(loItem)
Messagebox("创建菜单联系失败!请指定一个栏目对象或者栏目 KEY ", 16, "PopMenu.CreateContext")
Return .F.
Else
loItem.nFlags = MF_POPUP
loItem.oRefMenu = m.toPopMenu
EndIf
Return .T.
ENDPROC
PROCEDURE createmenus
LPARAMETERS toCollection, thMenu
Private loItem, loParent, loPopMenu, lnFlags, lcTitle, lcEnabled, llEnabled, lnAddress
Local loItem, loParent, loPopMenu, lnFlags, lcTitle, lcEnabled, llEnabled, lnAddress
If This.nMenuWidth = 0 Or This.nMenuHeight = 0
If Not This.InitItems()
MessageBox("初始化失败!", 16, "PopMenu.CreateMenus")
Return NULL
EndIf
EndIf
For Each loItem In This.oItems
toCollection.Add(m.loItem)
loItem.hParent = m.thMenu
loItem.lEnabled = .T.
loPopMenu = NULL
lcTitle = Left(loItem.cTitle2, This.nMaxLen)
lnFlags = loItem.nFlags
If Empty(m.lcTitle)
lnFlags = BitOr(m.lnFlags, MF_SEPARATOR)
EndIf
If Not Empty(loItem.cEnabled)
If Type("Evaluate(loItem.cEnabled)") = "L" ;
And Evaluate(loItem.cEnabled) = .F.
loItem.lEnabled = .F.
lnFlags = BitOr(m.lnFlags, BitOr(MF_GRAYED, MF_DISABLED))
EndIf
EndIf
lnFlags = BitOr(m.lnFlags, Iif(This.lOwnerDraw, MF_OWNERDRAW, MF_BYCOMMAND))
*-- 检效上下文联系菜单
If Not IsNull(loItem.oRefMenu)
Do Case
Case Vartype(loItem.oRefMenu) <> "O"
Case IsNull(loItem.oRefMenu)
Case Not loItem.oRefMenu.Class == This.Class
Otherwise
loPopMenu = loItem.oRefMenu
EndCase
EndIf
If Vartype(m.loPopMenu) = "O"
lnFlags = Bitor(m.lnFlags, MF_POPUP)
EndIf
*-- 申请与复制信息到内存
lnAddress = LocalAlloc(LPTR, This.nMaxLen + DWORD_SIZE)
loItem.nAddress = m.lnAddress
CopyStr2MemA(loItem.nAddress, m.lcTitle, Len(m.lcTitle))
CopyNum2MemA(loItem.nAddress + This.nMaxLen, toCollection.Count, 4)
If Vartype(This.oRefIcons) = "O" And Not IsNull(This.oRefIcons)
*-- 载入图标
loItem.hPic = This.oRefIcons.LoadImage(loItem.cPicture)
If Upper(Right(loItem.cPicture, 4)) = ".BMP"
*-- 载入位图掩码
loItem.hMsk = This.oRefIcons.LoadImage(ForceExt(loItem.cPicture, "msk"))
EndIf
EndIf
If Not Empty(loItem.cParentKey)
*-- 取父亲节点
loParent = This.oItems.Item(This.oItems.GetKey(loItem.cParentKey))
If loParent.hMenu = 0
*-- 异常出错
Loop
EndIf
Else
loParent = NULL
EndIf
*-- 这是一个子菜单项
If Bittest(m.lnFlags, 4) Or Not IsNull(loItem.oRefMenu)
loItem.hMenu = CreatePopupMenu()
If IsNull(m.loParent)
AppendMenu(m.thMenu, m.lnFlags, loItem.hMenu, m.lnAddress)
Else
loItem.hParent = m.loParent.hMenu
AppendMenu(m.loParent.hMenu, m.lnFlags, loItem.hMenu, m.lnAddress)
EndIf
*-- 指向另一个菜单,创建联接菜单
If Vartype(m.loPopMenu) = "O"
loPopMenu.CreateMenus(m.toCollection, loItem.hMenu)
EndIf
Else
If IsNull(m.loParent)
AppendMenu(m.thMenu, m.lnFlags, WM_USER + toCollection.Count, m.lnAddress)
Else
loItem.hParent = m.loParent.hMenu
AppendMenu(loParent.hMenu, m.lnFlags, WM_USER + toCollection.Count, m.lnAddress)
EndIf
EndIf
EndFor
Return .T.
ENDPROC
PROCEDURE declare_dlls
Declare Long SetForegroundWindow In "User32" ;
Long hwnd
Declare Long GetCursorPos In "User32" ;
String @lpPoint
Declare Long GetActiveWindow In "User32"
Declare Long GetWindowLong In "User32" ;
Long nhWnd, Long nIndex
Declare Long GetDC in "User32" ;
Long nhWnd
Declare Long GetSysColor In "User32" ;
Long nIndex
Declare Long GetSystemMetrics In "User32" ;
Long nIndex
Declare Long GetIconInfo In "User32";
Long hIcon, String @ piconinfo
Declare Long ClientToScreen In "User32" ;
Long nhWnd, String @lpPoint
Declare Long CallWindowProc In "User32" ;
Long lpPrevWndFunc, Long nhWnd, Long uMsg, Long wParam, Long lParam
Declare Long ReleaseDC In "User32" ;
Long nhWnd, Long hDC
Declare Long DrawText In "User32" ;
Long hDC, String lpString, Long nCount, ;
String @lpRect, Long uFormat
Declare Long DrawEdge In "User32" ;
Long hDC, String @lpRect, Long Edge, Long grfFlags
Declare Long DrawState In "User32" ;
Long hdc, Long hbr, Long lpOutputFunc, Long lData, ;
Long wData, Long x, Long y, Long cx, Long cy, Long fuFlags
Declare Long DrawIconEx In "User32" ;
Long hdc, Long xLeft, Long yTop, Long hIcon, ;
Long cxWidth, Long cyWidth, Long istepIfAniCur, ;
Long hbrFlickerFreeDraw, Long diFlags
Declare Long CreatePopupMenu In "User32"
Declare Long TrackPopupMenu In "User32" ;
Long hMenu, Long uFlags, Long x, Long y, ;
Long nReserved, Long hWnd, String @prcRect
Declare Long DestroyMenu In "User32" ;
Long hMenu
Declare Long AppendMenu In "User32" ;
Long hMenu, Long uFlags, Long uIDNewItem, Long lpNewItem
Declare Long ModifyMenu In "User32" ;
Long hmenu, Long uItem, Long fuFlags, Long idNewItem, Long lpszNewItem
Declare Long LocalAlloc In "Kernel32" ;
Long uFlags, Long dwBytes
Declare Long RtlMoveMemory In "Kernel32" As CopyMem2StrA ;
String @lpDest, Long lpSource, Long nLength
Declare Long RtlMoveMemory In "Kernel32" As CopyStr2MemA ;
Long lpDest, String @lpSource, Long nLength
Declare Long RtlMoveMemory In "Kernel32" As CopyMem2NumA ;
Long @lpDest, Long lpSource, Long nLength
Declare Long RtlMoveMemory In "Kernel32" As CopyNum2MemA ;
Long lpDest, Long @lpSource, Long nLength
Declare Long GetDeviceCaps In "Gdi32" ;
Long hDC, Long nIndex
Declare Long GetPixel In "Gdi32" ;
Long hDC, Long nXPos, Long nYPos
Declare Long GetTextExtentPoint32 In "Gdi32" ;
Long hDC, String cString, Long nStrLen, String @pSize
Declare Long CreateCompatibleDC In "Gdi32" ;
Long hDC
Declare Long CreateCompatibleBitmap In "Gdi32" ;
Long hdc, Long nWidth, Long nHeight
Declare Long CreateSolidBrush In "Gdi32" ;
Long crColor
Declare Long CreatePen In "Gdi32" ;
Long fnPenStyle, Long nWidth, Long crColor
Declare Long DeleteDC In "Gdi32" ;
Long hDC
Declare Long DeleteObject In "Gdi32" ;
Long hDC
Declare Long GetObject In "Gdi32" As GetObjectA ;
Long hGDIobj, Long nBufLen, String @lpvObject
Declare Long SelectObject In "Gdi32" ;
Long hDC, Long hObject
Declare Long SetTextColor In "Gdi32" ;
Long hDC, Long crColor
Declare Long SetBkColor In "Gdi32" ;
Long hDC, Long crColor
Declare Long SetBkMode In "Gdi32" ;
Long hDC, Long iBkMode
Declare Long MoveToEx In "Gdi32" ;
Long hDC, Long nX, Long nY, String @lpPoint
Declare Long LineTo In "Gdi32" ;
Long hDC, Long nEndX, Long nEndY
Declare Long FillRect In "User32" ;
Long hDC, String @lpRect, Long hBrush
Declare Long Rectangle In "Gdi32" ;
Long hDC, Long nLeftRect, Long nTopRect, ;
Long nRightRect, Long nBottomRect
Declare Long RoundRect In "Gdi32" ;
Long hdc, Long nLeftRect, Long nTopRect, Long nRightRect, ;
Long nBottomRect, Long nWidth, Long nHeight
Declare Long BitBlt In "Gdi32" ;
Long hdcDest, Long x, Long y, Long nWidth, Long nHeight, ;
Long pSrcDC, Long xSrc, Long ySrc, Long dwRop
Declare Long TransparentBlt In "MsImg32" ;
Long hdcDest, Long nXDest, Long nYDest, ;
Long nWidthDest, Long hHeightDest, ;
Long hdcSrc, Long nXSrc, Long nYSrc, ;
Long nWidthSrc, Long nHeightSrc, ;
Long crTransparent
ENDPROC
PROCEDURE Destroy
This.Clear()
ENDPROC
HIDDEN PROCEDURE destroymenus && I<>U菜单
Private loItem
Local loItem
If This.hMenu <> 0
*-- 销毁子菜单
If Vartype(This.oCollections) = "O"
For Each loItem In This.oCollections
If loItem.hMenu <> 0
DestroyMenu(loItem.hMenu)
loItem.hMenu = 0
EndIf
*-- 销毁图形内存
EndFor
EndIf
*-- 销毁主菜单
DestroyMenu(This.hMenu)
This.hMenu = 0
EndIf
ENDPROC
HIDDEN PROCEDURE drawgradualrect && 指定莖域后覣指定袿色绘制。可选水平或<E5B9B3>1直。
LPARAMETERS thDC, tnLeft, tnTop, tnRight, tnBottom, tnColor1, tnColor2, tnType, tnRate
* thDc 设备句柄
* tnLeft 绘制区域的左坐标
* tnTop 绘制区域的顶坐标
* tnRight 绘制区域的右坐标
* tnBottom 绘制区域的底坐标
* tnColor1 起始渐变色
* tnColor2 结束渐变色
* tnType 会制类型 0 水平绘制1 垂直绘制
Private lnStartR, lnStartG, lnStartB, lnRed, lnGreen, lnBlue, lnNowR, lnNowG, lnNowB
Private lnIndex, lnCount, lhOldPen, lhPen, lnAdd, lnRate
Local lnStartR, lnStartG, lnStartB, lnRed, lnGreen, lnBlue, lnNowR, lnNowG, lnNowB
Local lnIndex, lnCount, lhOldPen, lhPen, lnAdd, lnRate
*-- 水平过渡色
lnStartR = BitAnd(m.tnColor1, 0x0000FF)
lnStartG = BitRShift(BitAnd(m.tnColor1, 0x00FF00), 8)
lnStartB = BitRShift(BitAnd(m.tnColor1, 0xFF0000), 16)
lnRed = lnStartR - BitAnd(m.tnColor2, 0x0000FF)
lnGreen = lnStartG - BitRShift(BitAnd(m.tnColor2, 0x00FF00), 8)
lnBlue = lnStartB - BitRShift(BitAnd(m.tnColor2, 0xFF0000), 16)
*- 如果有传递 tnRate则按此比较计算用于只画整条渐变中的某一段局部
If Vartype(m.tnRate) = "N"
lnAdd = 0
lnRate = m.tnRate
lnIndex = Iif(tnType = 0, tnLeft, tnTop)
lnCount = Iif(tnType = 0, tnRight, tnBottom)
Else
lnIndex = 0
lnAdd = Iif(tnType = 0, tnLeft, tnTop)
lnCount = Iif(tnType = 0, tnRight - tnLeft, tnBottom - tnTop)
lnRate = lnCount - lnIndex
EndIf
lnIndex = lnIndex
lnCount = lnCount
For lnIndex = lnIndex To lnCount
lnNowR = m.lnStartR - Ceiling(lnIndex / lnRate * m.lnRed)
lnNowG = m.lnStartG - Ceiling(lnIndex / lnRate * m.lnGreen)
lnNowB = m.lnStartB - Ceiling(lnIndex / lnRate * m.lnBlue)
lhPen = CreatePen(PS_SOLID, 1, Rgb(m.lnNowR, m.lnNowG, m.lnNowB))
lhOldPen = SelectObject(m.thDC, m.lhPen)
If tnType = 0
*-- 水平绘制
MoveToEx(m.thDC, lnAdd + m.lnIndex - 1, m.tnTop, 0)
LineTo(m.thDC, lnAdd + m.lnIndex - 1, m.tnBottom)
Else
*-- 垂直绘制
MoveToEx(m.thDC, m.tnLeft, lnAdd + m.lnIndex - 1, 0)
LineTo(m.thDC, m.tnRight, lnAdd + m.lnIndex - 1)
EndIf
DeleteObject(m.lhPen)
SelectObject(thDC, lhOldPen)
EndFor
ENDPROC
HIDDEN PROCEDURE draw_bar && 画侧边Io
LPARAMETERS thDC, toItem, tnLeft, tnTop, tnRight, tnBottom
Private lcRect, lhBrush, lnFillColor1, lnFillColor2
Local lcRect, lhBrush, lnFillColor1, lnFillColor2
lnFillColor1 = Iif(This.nBarFillColor1 < 0, GetSysColor(COLOR_ACTIVECAPTION), This.nBarFillColor1)
lnFillColor2 = Iif(This.nBarFillColor2 < 0, GetSysColor(COLOR_GRADIENTACTIVECAPTION), This.nBarFillColor2)
*-- 画侧边栏
Do Case
Case This.nBarStyle = 0
*-- 无侧边栏
Case This.nBarStyle = 1
*-- 实色填充侧边栏
lcRect = This.Get_Rect_Str(tnLeft, tnTop, tnRight, tnBottom)
lhBrush = CreateSolidBrush(m.lnFillColor1)
FillRect(m.thDC, m.lcRect, m.lhBrush)
DeleteObject(m.lhBrush)
Case This.nBarStyle = 2
*-- 水平过渡色
This.DrawGradualRect(m.thDC, tnLeft, tnTop, tnRight, tnBottom, m.lnFillColor1, m.lnFillColor2, 0)
Case This.nBarStyle = 3
*-- 垂直过渡色
If This.nMenuHeight > 0
This.DrawGradualRect(thDC, tnLeft, tnTop, tnRight, tnBottom, lnFillColor2, lnFillColor1, 1, This.nMenuHeight)
EndIf
Case This.nBarStyle = 4
*-- 侧边栏贴图
EndCase
ENDPROC
HIDDEN PROCEDURE draw_image && 画图I<E59BBE>
LPARAMETERS thDC, toItem, tlEnabled, tnLeft, tnTop, tnRight, tnBottom
*-- 方法二,直接用 DrawState 绘制
Private lcExt, lhPic, lhMsk, lnLeft, lnTop, lnWidth, lnHeight, lsBitmap, lnBmpW, lnBmpH
Private lhMskDC, lhBmpDC, lhOldBmp, lhOldMsk, lhTmp
Local lExt, lhMsk, lcEXt, lnLeft, lnTop, lnWidth, lnHeight, lsBitmap, lnBmpW, lnBmpH
Local lhMskDC, lhBmpDC, lhOldBmp, lhOldMsk, lhTmp
Store 0 To lhMskDC, lhBmpDC, lhOldBmp, lhOldMsk, lhTmp
lcExt = Upper(JustExt(toItem.cPicture))
lhPic = toItem.hPic
lhMsk = toItem.hMsk
If m.lhPic = 0
Return
EndIf
*-- 计算图标置中位置
lnWidth = 16
lnHeight = 16
lnLeft = tnLeft + Int((tnRight - tnLeft - lnWidth) / 2)
lnTop = tnTop + Int((tnBottom - tnTop - lnHeight) / 2)
Do Case
Case lcExt == "BMP"
*!* lsBitmap = Replicate(Chr(0), BITMAP_SIZE)
*!* GetObjectA(lhPic, BITMAP_SIZE, @lsBitmap)
*!* lnBmpW = CToBin(Substr(lsBitmap, (DWORD_SIZE * 1) + 1, 4), "4Rs")
*!* lnBmpH = CToBin(Substr(lsBitmap, (DWORD_SIZE * 2) + 1, 4), "4Rs")
*-- 失效项图片变暗的处理
If Not tlEnabled
*-- 创建兼容设备,写入失效图后再拷回,黑色做为透明色
If lhMsk <> 0
lhPic = lhMsk
EndIf
lhBmpDc = CreateCompatibleDC(thDC)
lhTmp = CreateCompatibleBitmap(thDC, lnWidth, lnHeight)
lhOldBmp = SelectObject(lhBmpDc, lhTmp)
DrawState(lhBmpDC, 0, 0, lhPic, 0, 0, 0, lnWidth, lnHeight, DST_BITMAP + DSS_DISABLED)
TransparentBlt(thDC, lnLeft, lnTop, lnWidth, lnHeight, ;
lhBmpDc, 0, 0, lnWidth, lnHeight, Rgb(0, 0, 0))
DeleteObject(lhTmp)
SelectObject(lhBmpDc, lhOldBmp)
DeleteDC(lhBmpDc)
Return
EndIf
*-- 透明原理 (掩图 And 背景图) Or (掩图 Xor 图象)
*-- 正常图片的显示处理
If m.lhMsk = 0
*-- BMP 无掩码,使用图标 0, 0 坐标的色彩点做为透明色
lhBmpDc = CreateCompatibleDC(thDC)
lhOldBmp = SelectObject(lhBmpDc, lhPic)
*-- 取图标 0, 0 坐标做为透明点
TransparentBlt(thDC, lnLeft, lnTop, lnWidth, lnHeight, ;
lhBmpDc, 0, 0, lnWidth-1, lnHeight-1, GetPixel(lhBmpDc, 0, 0))
Else
*-- BMP 有掩码图片,进行透明化处理
*-- 使用黑白掩码透明原理 (掩图 Xor 图象) Or (掩图 And 背景图)
lhBmpDC = CreateCompatibleDC(thDc)
lhMskDC = CreateCompatibleDC(thDc)
SelectObject(lhBmpDC, lhPic)
SelectObject(lhMskDC, lhMsk)
*-- 背景为黑,前景为白,将掩码与图象相"与",从图象中去掉 MSK 中的白色部份
SetBkColor(lhBmpDC, Rgb(0,0,0))
SetTextColor(lhBmpDC, Rgb(255,255,255))
BitBlt(lhBmpDC, 0, 0, lnWidth, lnHeight, lhMskDC, 0, 0, SRCAND)
*-- 反转黑白,将掩码位图与背景进行“与”运算,从背景去掉 MSK 中的黑色部份
SetBkColor(thDC, Rgb(255,255,255))
SetTextColor(thDC, Rgb(0,0,0))
BitBlt(thDC, lnLeft, lnTop, lnWidth, lnHeight, lhMskDC, 0, 0, SRCAND)
*-- 将图象与背景进行“或”运算,或运算:两图黑色区域都被保留
BitBlt(thDC, lnLeft, lnTop, lnWidth, lnHeight, lhBmpDC, 0, 0, SRCPAINT)
EndIf
If lhBmpDc <> 0
If lhOldBmp <> 0
SelectObject(lhBmpDc, lhOldBmp)
EndIf
DeleteDC(lhBmpDc)
EndIf
If lhMskDc <> 0
If lhOldMsk <> 0
SelectObject(lhMskDc, lhOldMsk)
EndIf
DeleteDC(lhMskDc)
EndIf
Case lcExt == "ICO"
If tlEnabled
DrawIconEx(thDC, lnLeft, lnTop, lhPic, lnWidth, lnHeight, 0, 0, DI_NORMAL)
Return
EndIf
lsBitmap = Replicate(Chr(0), ICONINFO_SIZE)
GetIconInfo(lhPic, @lsBitmap)
lnBmpW = CToBin(Substr(lsBitmap, 5, 4), "4Rs") * 2
lnBmpH = CToBin(Substr(lsBitmap, 9, 4), "4Rs") * 2
lhBmpDc = CreateCompatibleDC(thDC)
lhTmp = CreateCompatibleBitmap(thDC, lnBmpW, lnBmpH)
lnOldBmp = SelectObject(lhBmpDc, lhTmp)
DeleteObject(lhTmp)
If tlEnabled
DrawState(lhBmpDc, 0, 0, lhPic, 0, 0, 0, lnBmpW, lnBmpH, DST_ICON)
Else
DrawState(lhBmpDc, 0, 0, lhPic, 0, 0, 0, lnBmpW, lnBmpH, DST_ICON + DSS_DISABLED)
EndIf
TransparentBlt(thDC, lnLeft, lnTop, lnWidth, lnHeight, ;
lhBmpDc, 0, 0, lnBmpW, lnBmpH, Rgb(0, 0, 0))
SelectObject(lhBmpDc, lhOldBmp)
DeleteDC(lhBmpDc)
Otherwise
*!* *-- 尝试用 DrawState 是否可显示
*!* If Not tlEnabled
*!* DrawState(thDC, 0, 0, lhPic, 0, tnLeft, tnTop, lnWidth, lnHeight, DST_BITMAP + DSS_DISABLED)
*!* Else
*!* DrawState(thDC, 0, 0, lhPic, 0, tnLeft, tnTop, lnWidth, lnHeight, DST_BITMAP)
*!* EndIf
EndCase
ENDPROC
HIDDEN PROCEDURE draw_selected && 绘制选定
LPARAMETERS thDC, toItem, tlEnabled, tnLeft, tnTop, tnRight, tnBottom, tnBmpLeft, tnTxtLeft
*-- tnLeft 区块左边距
*-- tnTop 区块顶边距
*-- tnWidth 区块高度
*-- tnHeight 区块宽度
*-- tnBmpLeft 位图左边距
*-- tnTxtLeft 文本械边距
Private lcTmpRect, llImage, lnColor, lnPen, lhBrush, lhOldPen, lhOldBrush, lnLeft, lnBmpRight, lnFillColor, lnColor1, lnColor2
Local lcTmpRect, llImage, lnColor, lnPen, lhBrush, lhOldPen, lhOldBrush, lnLeft, lnBmpRight, lnFillColor, lnColor1, lnColor2
If This.lSelectedEnabled And Not tlEnabled
Return
EndIf
llImage = toItem.hPic <> 0
*-- 矩形选定时,如果没有指定背景色,取边框色到菜单背景过渡色
If This.nSelectedBackColor < 0
lnColor1 = Iif(This.nSelectedBorderColor < 0, GetSysColor(COLOR_HIGHLIGHT), This.nSelectedBorderColor)
lnColor2 = Iif(This.nMenuBackColor < 0, GetSysColor(COLOR_MENU), This.nMenuBackColor)
lnFillColor = This.GetHalfColor(lnColor1, lnColor2, 80)
Else
lnFillColor = This.nSelectedBackColor
EndIf
*!* If This.nMenuBackColor < 0
*!* lnFillColor = This.GetHalfColor(GetSysColor(COLOR_HIGHLIGHT), GetSysColor(COLOR_MENU), 80)
*!* Else
*!* lnFillColor = This.GetHalfColor(GetSysColor(COLOR_HIGHLIGHT), This.nMenuBackColor, 80)
*!* EndIf
*!* Else
*!* lnFillColor = This.nSelectedBackColor
*!* EndIf
*-- 设置默认左边距
lnLeft = Min(tnBmpLeft, tnTxtLeft)
lnBmpRight = tnBmpLeft + (m.tnBottom-m.tnTop)
*-- 绘制图标区
If llImage And This.nSelectedImageStyle > 0
lnLeft = tnTxtLeft
*-- 图标需要有自己的绘图风格时
Do Case
Case InList(This.nSelectedImageStyle, 1, 2)
*-- 矩形选定框、椭圆选定框
lnColor = Iif(This.nSelectedBorderColor < 0, GetSysColor(COLOR_HIGHLIGHT), This.nSelectedBorderColor)
lhPen = CreatePen(PS_SOLID, 1, lnColor)
lnOldPen = SelectObject(thDC, lhPen)
lhBrush = CreateSolidBrush(lnFillColor)
lhOldBrush = SelectObject(thDC, lhBrush)
If This.nSelectedImageStyle = 1
*-- 矩形
Rectangle(thDc, tnBmpLeft, tnTop, lnBmpRight, tnBottom)
Else
*-- 圆角
RoundRect(thDc, tnBmpLeft, tnTop, lnBmpRight, tnBottom, This.nSelectedRoundX, This.nSelectedRoundY)
EndIf
DeleteObject(lhPen)
DeleteObject(lhBrush)
SelectObject(thDc, lhOldPen)
SelectObject(thDc, lhOldBrush)
Case InList(This.nSelectedImageStyle, 3, 4)
*-- 凸起选定框、凹下选定框
If This.nSelectedBackColor > -1
*-- 是否需要填充背景
lnColor = Iif(This.nSelectedBackColor < 0, GetSysColor(COLOR_HIGHLIGHT), This.nSelectedBackColor)
lhBrush = CreateSolidBrush(lnColor)
lcTmpRect = This.Get_Rect_Str(tnBmpLeft, tnTop, lnBmpRight, tnBottom)
FillRect(thDC, lcTmpRect, lhBrush)
If llImage And This.nSelectedImageStyle = 2
lcTmpRect = This.Get_Rect_Str(tnBmpLeft, tnTop, lnBmpRight, tnBottom)
FillRect(thDC, lcTmpRect, lhBrush)
EndIf
DeleteObject(m.lhBrush)
EndIf
lcTmpRect = This.Get_Rect_Str(tnBmpLeft, tnTop, lnBmpRight, tnBottom)
If This.nSelectedImageStyle = 3
DrawEdge(thDC, lcTmpRect, BDR_RAISEDINNER, BF_RECT)
Else
DrawEdge(thDC, lcTmpRect, BDR_SUNKENOUTER, BF_RECT)
EndIf
Otherwise
EndCase
EndIf
*-- 绘制文本区
Do Case
Case This.nSelectedStyle = 0
*-- 标准选定
lnColor = Iif(This.nSelectedBackColor < 0, GetSysColor(COLOR_HIGHLIGHT), This.nSelectedBackColor)
lhBrush = CreateSolidBrush(lnColor)
lcTmpRect = This.Get_Rect_Str(lnLeft, tnTop, tnRight, tnBottom)
FillRect(thDC, lcTmpRect, lhBrush)
If llImage And This.nSelectedImageStyle = 2
lcTmpRect = This.Get_Rect_Str(lnLeft, tnTop, lnBmpRight, tnBottom)
FillRect(thDC, lcTmpRect, lhBrush)
EndIf
DeleteObject(m.lhBrush)
Case InList(This.nSelectedStyle, 1, 2)
*-- 矩形选定框、椭圆选定框
lnColor = Iif(This.nSelectedBorderColor = -1, GetSysColor(COLOR_HIGHLIGHT), This.nSelectedBorderColor)
lhPen = CreatePen(PS_SOLID, 1, lnColor)
lnOldPen = SelectObject(thDC, lhPen)
lhBrush = CreateSolidBrush(lnFillColor)
lhOldBrush = SelectObject(thDC, lhBrush)
If This.nSelectedStyle = 1
*-- 矩形
Rectangle(thDc, lnLeft, tnTop, tnRight, tnBottom)
Else
*-- 圆角
RoundRect(thDc, lnLeft, tnTop, tnRight, tnBottom, This.nSelectedRoundX, This.nSelectedRoundY)
EndIf
DeleteObject(lhPen)
DeleteObject(lhBrush)
SelectObject(thDc, lhOldPen)
SelectObject(thDc, lhOldBrush)
Case InList(This.nSelectedStyle, 3, 4)
*-- 凸起选定框、凹下选定框
If This.nSelectedBackColor > 0
*-- 是否需要填充背景
lnColor = Iif(This.nSelectedBackColor = -1, GetSysColor(COLOR_HIGHLIGHT), This.nSelectedBackColor)
lhBrush = CreateSolidBrush(lnColor)
lcTmpRect = This.Get_Rect_Str(lnLeft, tnTop, tnRight, tnBottom)
FillRect(thDC, lcTmpRect, lhBrush)
If llImage And This.nSelectedImageStyle = 2
lcTmpRect = This.Get_Rect_Str(lnLeft, tnTop, tnRight, tnBottom)
FillRect(thDC, lcTmpRect, lhBrush)
EndIf
DeleteObject(m.lhBrush)
EndIf
lcTmpRect = This.Get_Rect_Str(lnLeft, tnTop, tnRight, tnBottom)
If This.nSelectedStyle = 3
DrawEdge(thDC, lcTmpRect, BDR_RAISEDINNER, BF_RECT)
Else
DrawEdge(thDC, lcTmpRect, BDR_SUNKENOUTER, BF_RECT)
EndIf
Otherwise
EndCase
ENDPROC
HIDDEN PROCEDURE draw_separator
LPARAMETERS thDC, tnLeft, tnTop, tnRight, tnBottom
Private lcRect
Local lcRect
lcRect = This.Get_Rect_Str(tnLeft, tnTop + 2, tnRight, tnBottom)
DrawEdge(m.thDC, lcRect, EDGE_ETCHED, BF_TOP)
ENDPROC
HIDDEN PROCEDURE draw_text && 画文盻莖
LPARAMETERS thDC, tcText, tnColor, tnLeft, tnTop, tnRight, tnBottom
Private lcRect, lnOldHdc, lhPen
Local lcRect, lnOldHdc, lhPen
lcRect = This.Get_Rect_Str(m.tnLeft + This.nTextMargin, m.tnTop, m.tnRight, m.tnBottom)
SetTextColor(m.thDC, m.tnColor)
DrawText(m.thDC, m.tcText, Len(m.tcText), m.lcRect, DT_SINGLELINE + DT_LEFT + DT_VCENTER)
ENDPROC
HIDDEN PROCEDURE gethalfcolor && E×<C397><E7BCB4>涞陌肷<E9998C><E882B7>
LPARAMETERS tnColor1, tnColor2, tnRate
* thDc 设备句柄
* tnColor1 起始渐变色
* tnColor2 结束渐变色
* tnRate 半色调的比率
Private lnStartR, lnStartG, lnStartB, lnRed, lnGreen, lnBlue, lnNowR, lnNowG, lnNowB
Local lnStartR, lnStartG, lnStartB, lnRed, lnGreen, lnBlue, lnNowR, lnNowG, lnNowB
lnStartR = BitAnd(m.tnColor1, 0x0000FF)
lnStartG = BitRShift(BitAnd(m.tnColor1, 0x00FF00), 8)
lnStartB = BitRShift(BitAnd(m.tnColor1, 0xFF0000), 16)
lnRed = lnStartR - BitAnd(m.tnColor2, 0x0000FF)
lnGreen = lnStartG - BitRShift(BitAnd(m.tnColor2, 0x00FF00), 8)
lnBlue = lnStartB - BitRShift(BitAnd(m.tnColor2, 0xFF0000), 16)
Return Rgb(lnStartR - lnRed / 100 * tnRate, ;
lnStartG - lnGreen / 100 * tnRate, ;
lnStartB - lnBlue / 100 * tnRate)
ENDPROC
HIDDEN PROCEDURE gethwnd && 获E〈翱赺浔<E8B5BA>
If This.nHwnd = 0
Do Case
Case Type("_Screen.ActiveForm.Hwnd") = "N"
This.nHwnd = _Screen.ActiveForm.Hwnd
Case _Screen.Visible
This.nHwnd = _Screen.Hwnd
Otherwise
This.nHwnd = GetActiveWindow()
EndCase
EndIf
Return This.nHwnd
ENDPROC
HIDDEN PROCEDURE get_rect_num && 从 Rect 结11諨返籓E<E7B193><EFBFBD><E680A0>1<EFBFBD><EFBFBD>说O址参E<E58F82><45><EFBFBD>1<EFBFBD>娴降O址参E<E58F82>D。
LPARAMETERS tcRect, tnRefLeft, tnRefTop, tnRefRight, tnRefBottom
tnRefLeft = CToBin(Substr(m.tcRect, DWORD_SIZE * 0 + 1, DWORD_SIZE), "4rs")
tnRefTop = CToBin(Substr(m.tcRect, DWORD_SIZE * 1 + 1, DWORD_SIZE), "4rs")
tnRefRight = CToBin(Substr(m.tcRect, DWORD_SIZE * 2 + 1, DWORD_SIZE), "4rs")
tnRefBottom = CToBin(Substr(m.tcRect, DWORD_SIZE * 3 + 1, DWORD_SIZE), "4rs")
ENDPROC
HIDDEN PROCEDURE get_rect_str && 传递 Left, Top, Right, Bottom 四个参E<E58F82><45>祷O RECT 结11样的字符串。
LPARAMETERS m.tnLeft, tnTop, tnRight, tnBottom
Return BinToC(m.tnLeft, "4rs") ;
+ BinToC(m.tnTop, "4rs") ;
+ BinToC(m.tnRight, "4rs") ;
+ BinToC(m.tnBottom, "4rs")
ENDPROC
PROCEDURE Init
Private lcClass, lcClassLibrary, lcRetClassLibrary
Local lcClass, lcClassLibrary, lcRetClassLibrary
If Not PemStatus(_Screen, This.Class, 5)
This.Declare_Dlls()
_Screen.AddProperty(This.Class, .T.)
EndIf
lcClass = This.Class
lcClassLibrary = This.ClassLibrary
lcRetClassLibrary = m.lcClassLibrary
Do While Not Empty(m.lcClassLibrary)
lcClass = GetPem(m.lcClass, "ParentClass")
lcClassLibrary = GetPem(m.lcClass, "ClassLibrary")
If Not Empty(m.lcClassLibrary)
m.lcRetClassLibrary = m.lcClassLibrary
EndIf
EndDo
This.ClassLibraryRoot = m.lcRetClassLibrary
If This.lShareIcons = .T.
If Not PemStatus(_Screen, "oRefIcons", 5) Or Not Type("_Screen.oRefIcons.Name") = "C"
_Screen.AddProperty("oRefIcons", NULL)
_Screen.oRefIcons = NewObject("IconCollection", This.ClassLibraryRoot)
EndIf
This.oRefIcons = _Screen.oRefIcons
Else
This.oRefIcons = NewObject("IconCollection", This.ClassLibraryRoot)
EndIf
This.oItems = NewObject("Collection")
ENDPROC
HIDDEN PROCEDURE inititems && 3oE蓟_A改緿臝<E7B7BF>
*-- 计算最大字符长度
*-- 计算各个栏目所需宽高
Private lhWnd, lhDC, loItem, lcTitle, lsSize, lnMaxH, lnMaxW, lnValH, lnValW
Local lhWnd, loItem, loItem, lcTitle, lhDC, lsSize, lnMaxH, lnMaxW, lnValH, lnValW
lhWnd = This.GetHwnd()
lhDC = GetDC(m.lhWnd)
If m.lhDC = 0
Return .F.
EndIf
Store 0 To lnMaxH, lnMaxW, lnValH, lnValW
For Each loItem In This.oItems
*-- 校对
lcTitle = loItem.cTitle
lcTitle = Strtran(m.lcTitle, "\<", "&")
lcTitle = Iif(m.lcTitle == "\-", "", m.lcTitle)
loItem.cTitle2 = m.lcTitle
loItem.cMessage = Iif(IsNull(loItem.cMessage), Strtran(m.lcTitle, "&", ""), loItem.cMessage)
loItem.cEnabled = Transform(loItem.cEnabled)
*-- 计算文本宽度
lsSize = Replicate(Chr(0), POINT_SIZE)
GetTextExtentPoint32(m.lhDC, m.lcTitle, Len(m.lcTitle), @m.lsSize)
*-- 处理栏目高度
Do Case
Case Empty(m.lcTitle)
loItem.nHeight = 5
Case loItem.nHeight > 0
*-- 使用己有高度
Otherwise
loItem.nHeight = CToBin(Substr(m.lsSize, 5, DWORD_SIZE), "4rs") + 7
EndCase
*-- 处理栏目宽度
Do Case
Case loItem.nWidth > 0
*-- 使用自定义宽度
Otherwise
loItem.nWidth = CToBin(Substr(m.lsSize, 1, DWORD_SIZE), "4rs") ;
+ GetSystemMetrics(SM_CXMENUCHECK) + loItem.nHeight + This.nTextMargin ;
+ Max(0, Min(This.nImageLeft, This.nTextLeft))
EndCase
If Not Empty(loItem.cParentKey)
Loop
EndIf
If BitTest(loItem.nFlags, 5)
lnMaxW = m.lnMaxW + 20 + m.lnValW
lnMaxH = Max(m.lnMaxH, m.lnValH)
lnValW = 0
lnValH = 0
EndIf
lnValW = Max(m.lnValW, loItem.nWidth)
lnValH = m.lnValH + loItem.nHeight
EndFor
This.nMenuWidth = m.lnMaxW + m.lnValW
This.nMenuHeight = Max(m.lnValH, m.lnMaxH)
ReleaseDC(m.lhWnd, m.lhDC)
Return .T.
ENDPROC
PROCEDURE modifymenus && D_改菜单的 Enabled 状I<E78AB6>
Private loItem, lnItem, lnIndex, lhMenu, lnFlags
Local loItem, lnItem, lnIndex, lhMenu, lnFlags
If Not Vartype(This.oCollections) = "O" ;
Or IsNull(This.oCollections)
Return
EndIf
For lnIndex = 1 To This.oCollections.Count
loItem = This.oCollections.Item(m.lnIndex)
If Vartype(m.loItem) <> "O" Or IsNull(m.loItem)
Loop
EndIf
If Empty(loItem.cEnabled)
Loop
EndIf
If Not Type("Evaluate(loItem.cEnabled)") = "L"
Loop
EndIf
lnFlags = loItem.nFlags
lnItem = WM_USER + m.lnIndex
lhMenu = Iif(loItem.hMenu = 0, This.hMenu, loItem.hMenu)
If Evaluate(loItem.cEnabled) = .F.
loItem.lEnabled = .F.
lnFlags = BitOr(lnFlags, BitOr(MF_GRAYED, MF_DISABLED))
Else
loItem.lEnabled = .T.
lnFlags = BitAnd(lnFlags, BitAnd(MF_GRAYED, MF_DISABLED))
EndIf
lnFlags = BitOr(m.lnFlags, Iif(This.lOwnerDraw, MF_OWNERDRAW, MF_BYCOMMAND))
ModifyMenu(m.lhMenu, m.lnItem, lnFlags, m.lnItem, loItem.nAddress)
EndFor
ENDPROC
HIDDEN PROCEDURE newitem && 获E<E88EB7>桓鯝改慷訧<E685B7>
Private loItem
Local loItem
Return NewObject("_MenuInfo", This.ClassLibraryRoot)
loItem = NewObject("Custom")
loItem.AddProperty("cKey", "") && 栏目 Key
loItem.AddProperty("cParentKey", "") && 父栏目 Key
loItem.AddProperty("nIndex", 0) && 下标
loItem.AddProperty("nAddress", 0) && 栏目地址
loItem.AddProperty("cTitle", "") && 栏目文本
loItem.AddProperty("cTitle2", "") && 被格式化处理后的栏目文本
loItem.AddProperty("cCommand", "") && 命令关键字
loItem.AddProperty("cEnabled", "") && Enabled 表达式
loItem.AddProperty("cPicture", "") && 图标
loItem.AddProperty("cMessage", NULL) && 信息提示
loItem.AddProperty("hParent", 0) && 父亲句柄
loItem.AddProperty("hMenu", 0) && 如果是子菜单,保存菜单句柄
loItem.AddProperty("hMsk", 0) && 图标掩码句柄
loItem.AddProperty("hPic", 0) && 图标句柄
loItem.AddProperty("nFlags", 0) && uFlags
loItem.AddProperty("nHeight", 0) && 栏目高度
loItem.AddProperty("nWidth", 0) && 栏目宽度
Return m.loItem
ENDPROC
PROCEDURE setmessage && 设諥菜单I钭碔珹窱酔_D臝ⅲ<E8879D>诙_参指物A聿说<E881BF>畹腄蚝牛珽盓<E78FBD>1覣最近I砑拥牟说ァ<E8AFB4>
LPARAMETERS tcMessage, tnOrder
Private lnOrder
Local lnOrder
If Vartype(m.tnOrder) = "N"
lnOrder = m.tnOrder
Else
lnOrder = This.oItems.Count
EndIf
If Not BetWeen(m.lnOrder, 1, This.oItems.Count)
MessageBox("指定的索引号超过菜单项目号!", 16, "PopMenu.SetMessage")
Return
EndIf
This.oItems.Item(m.lnOrder).cMessage = m.tcMessage
ENDPROC
PROCEDURE setpicture && 设諥菜单I畹耐计<E88090><E8AEA1>诙_参指物A聿说<E881BF>頓蚝牛珽盓<E78FBD>1覣最近I砑拥牟说ァ<E8AFB4>
LPARAMETERS tcPicFile, tnOrder
Private lnOrder
Local lnOrder
If Vartype(m.tnOrder) = "N"
lnOrder = m.tnOrder
Else
lnOrder = This.oItems.Count
EndIf
If Not BetWeen(lnOrder, 1, This.oItems.Count)
MessageBox("指定的索引号超过菜单项目号!", 16, "PopMenu.SetPicture")
Return
EndIf
This.oItems.Item(m.lnOrder).cPicture = m.tcPicFile
ENDPROC
PROCEDURE show && I訣_菜单在指定的 x,y 護标外E<EFBC8C>1<EFBFBD>粗付ǎ<E4BB98><C78E>诘鼻癊蟊晡恢AI訣_。
Lparameters tnX, tnY, tlAbsolute, tuFlags
*!* 所覦预定O宓目O制菜单I睿瞋虴荌低3菜单的ID号監D氪笥<E6B0AA> 0xF000。E<E38082>1<EFBFBD>3个应覣3ID騉狪砑覫低3菜单
*!* 其I低3菜单的 ID 号監D隓∮贔000。”
*-- tnX x 座标
*-- tnY y 座标
*-- tlAbsolute 此座标E欠馹o对護标
*-- tuFlags 自定O<E5AE9A> TrackPopmenuEx uFlags
Private lcPoint, lnX, lnY, lnFlags, lnReturn, loItem
Local lcPoint, lnX, lnY, lnFlags, lnReturn, loItem
This.GetHwnd()
If This.nHwnd = 0
Messagebox("3oE蓟_EО<D09E>", 16, "PopMenu.ShowBy")
Return Null
Endif
If Pcount() >= 2
*-- 在指定護标礯3<E7A4AF>
lnX = Iif(Vartype(m.tnX) = "N", m.tnX, 0)
lnY = Iif(Vartype(m.tnY) = "N", m.tnY, 0)
If Not m.tlAbsolute
*-- 此座标E荌喽云聊恢<E8818A>
lcPoint = Replicate(Chr(0), DWORD_SIZE * 2)
ClientToScreen(This.nHwnd, @lcPoint)
lnX = lnX + CToBin(Left(m.lcPoint, DWORD_SIZE), "4rs")
lnY = lnY + CToBin(Right(m.lcPoint, DWORD_SIZE), "4rs")
Endif
Else
*-- E<>蟊甑鼻拔恢A
lcPoint = Replicate(Chr(0), DWORD_SIZE * 2)
GetCursorPos(@m.lcPoint)
lnX = CToBin(Left(m.lcPoint, DWORD_SIZE), "4rs")
lnY = CToBin(Right(m.lcPoint, DWORD_SIZE), "4rs")
Endif
***
*** 开E即唇<E58DB3>
***
If This.hMenu <> 0
*-- 菜单己创建D_改菜单I钅贓<E99285>
This.ModifyMenus()
Else
*-- 菜单未创建,创建菜单
This.oCollections = Null
This.oCollections = Newobject("Collection")
This.hMenu = CreatePopupMenu()
This.CreateMenus(This.oCollections, This.hMenu)
Endif
*
This.BindEvents(.T.)
*-- 礯3龇紼<E9BE87>
If Vartype(m.tuFlags) = "N"
lnFlags = Bitor(m.tuFlags, TPM_RETURNCMD)
Else
lnFlags = TPM_LEFTALIGN + TPM_TOPALIGN + TPM_RETURNCMD
Endif
SetForegroundWindow(This.nHwnd)
lnReturn = TrackPopupMenu(This.hMenu, m.lnFlags, Max(m.lnX, 0), Max(m.lnY, 0), 0, This.nHwnd, Null)
This.BindEvents(.F.)
If m.lnReturn > 0
lnReturn = m.lnReturn - WM_USER
loItem = This.oCollections.Item(m.lnReturn)
lcCommand = loItem.cCommand
If Not Empty(m.lcCommand)
&lcCommand
Endif
*!* If Not Empty(m.lcCommand)
*!* If Version(5) >= 900
*!* ExecScript(m.lcCommand)
*!* Else
*!* &lcCommand
*!* EndIf
*!* EndIf
Do Case
Case This.nReturn = 0
*-- 索O<E7B4A2>
Return loItem.nIndex
Case This.nReturn = 1
*-- cKey
Return loItem.cKey
Case This.nReturn = 2
*-- A改课谋_
Return loItem.cTitle
Case This.nReturn = 3
*-- 对I<E5AFB9>
Return m.loItem
Otherwise
Return Null
Endcase
Else
Return Null
Endif
ENDPROC
PROCEDURE showby && 指定表单的<E58D95>3个对I螅<49><E89E85>诟A对I蟮腎路降_3霾说ァ<E8AFB4>
LPARAMETERS toObject, tnAddX, tnAddY
Private loForm, lcBaseClass, lcPoint, lnTop, lnLeft, luFlags
Local loForm, lcBaseClass, lcPoint, lnTop, lnLeft, luFlags
If This.nMaxLen = 0
If Not This.InitMenu()
MessageBox("初始化失败!", 16, "PopMenu.ShowBy")
Return
EndIf
EndIf
loForm = toObject
lcBaseClass = Upper(toObject.BaseClass)
Do While Not InList(m.lcBaseClass, "FORM", "TOOLBAR")
loForm = loForm.Parent
lcBaseClass = Upper(loForm.BaseClass)
EndDo
lcPoint = BinToC(ObjToClient(m.toObject, 2), "4rs") + BinToC(ObjToClient(m.toObject, 1), "4rs")
ClientToScreen(loForm.Hwnd, @m.lcPoint)
lnLeft = CToBin(Left(m.lcPoint, 4), "4rs")
lnTop = CToBin(Right(m.lcPoint, 4), "4rs")
If Vartype(m.tnAddX) = "N"
lnLeft = m.lnLeft + m.tnAddX
EndIf
If Vartype(m.tnAddY) = "N"
lnTop = m.lnTop + m.tnAddY
EndIf
*-- 检查屏幕范围
If m.lnLeft + This.nMenuWidth + 17 >= Sysmetric(1)
luFlags = TPM_RIGHTALIGN
lnLeft = m.lnLeft + m.toObject.Width
If m.lnLeft + This.nMenuWidth + 17 >= Sysmetric(1)
lnLeft = Sysmetric(1)
EndIf
Else
luFlags = TPM_LEFTALIGN
EndIf
If m.lnTop + This.nMenuHeight + 62 > Sysmetric(2)
luFlags = BitOr(m.luFlags, TPM_BOTTOMALIGN)
m.lnTop = CToBin(Right(m.lcPoint, 4), "4rs") - toObject.Height
Else
luFlags = BitOr(m.luFlags, TPM_TOPALIGN)
EndIf
Return This.Show(m.lnLeft, m.lnTop + m.toObject.Height, .T., m.luFlags)
ENDPROC
PROCEDURE transparentblta && See win32Api TransparentBlt
LPARAMETERS hdcDest, nXOriginDest, nYOriginDest, nHeightDest, ;
hdcSrc, nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc, crTransparent
*!* HDC hdcDest // 目标DC
*!* int nXOriginDest // 目标X偏移
*!* int nYOriginDest // 目标Y偏移
*!* int nWidthDest // 目标宽度
*!* int nHeightDest // 目标高度
*!* HDC hdcSrc // 源DC
*!* int nXOriginSrc // 源X起点
*!* int nYOriginSrc // 源Y起点
*!* int nWidthSrc // 源宽度
*!* int nHeightSrc // 源高度
*!* UINT crTransparent // 透明色,COLORREF类型
*!* HBITMAP hOldImageBMP, hImageBMP = CreateCompatibleBitmap(hdcDest, nWidthDest, nHeightDest); // 创建兼容位图
*!* HBITMAP hOldMaskBMP, hMaskBMP = CreateBitmap(nWidthDest, nHeightDest, 1, 1, NULL); // 创建单色掩码位图
*!* HDC hImageDC = CreateCompatibleDC(hdcDest);
*!* HDC hMaskDC = CreateCompatibleDC(hdcDest);
*!* hOldImageBMP = (HBITMAP)SelectObject(hImageDC, hImageBMP);
*!* hOldMaskBMP = (HBITMAP)SelectObject(hMaskDC, hMaskBMP);
*!* // 将源DC中的位图拷贝到临时DC中
*!* if (nWidthDest == nWidthSrc && nHeightDest == nHeightSrc)
*!* BitBlt(hImageDC, 0, 0, nWidthDest, nHeightDest, hdcSrc, nXOriginSrc, nYOriginSrc, SRCCOPY);
*!* else
*!* StretchBlt(hImageDC, 0, 0, nWidthDest, nHeightDest,
*!* hdcSrc, nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc, SRCCOPY);
*!* // 设置透明色
*!* SetBkColor(hImageDC, crTransparent);
*!* // 生成透明区域为白色,其它区域为黑色的掩码位图
*!* BitBlt(hMaskDC, 0, 0, nWidthDest, nHeightDest, hImageDC, 0, 0, SRCCOPY);
*!* // 生成透明区域为黑色,其它区域保持不变的位图
*!* SetBkColor(hImageDC, RGB(0,0,0));
*!* SetTextColor(hImageDC, RGB(255,255,255));
*!* BitBlt(hImageDC, 0, 0, nWidthDest, nHeightDest, hMaskDC, 0, 0, SRCAND);
*!* // 透明部分保持屏幕不变,其它部分变成黑色
*!* SetBkColor(hdcDest,RGB(255,255,255));
*!* SetTextColor(hdcDest,RGB(0,0,0));
*!* BitBlt(hdcDest, nXOriginDest, nYOriginDest, nWidthDest, nHeightDest, hMaskDC, 0, 0, SRCAND);
*!* // "或"运算,生成最终效果
*!* BitBlt(hdcDest, nXOriginDest, nYOriginDest, nWidthDest, nHeightDest, hImageDC, 0, 0, SRCPAINT);
*!* // 清理、恢复
*!* SelectObject(hImageDC, hOldImageBMP);
*!* DeleteDC(hImageDC);
*!* SelectObject(hMaskDC, hOldMaskBMP);
*!* DeleteDC(hMaskDC);
*!* DeleteObject(hImageBMP);
*!* DeleteObject(hMaskBMP);
*!* }
ENDPROC
ENDDEFINE
DEFINE CLASS tooltipex AS control
*< CLASSDATA: Baseclass="control" Timestamp="" Scale="Pixels" Uniqueid="" />
*-- OBJECTDATA items order determines ZOrder / El orden de los items OBJECTDATA determina el ZOrder
*< OBJECTDATA: ObjPath="Label1" UniqueID="" Timestamp="" />
#INCLUDE "win32api.h"
*<DefinedPropArrayMethod>
*m: about
*m: addcontrol && 对一个表单控件添加提示
*m: addmessage && 添加一个对象信息,在获得焦点与失去焦点时,显示信息。
*m: b_gotfocus && 绑定到对象 GotFocus 事件
*m: createtrackwindow
*m: declare_dlls
*m: getstructvalue
*m: hide && 通过设置 Visible 属性为“假”(.F.),隐藏一个表单,表单集或工具栏。
*m: show && 在指定控件上显示控件提示。Show(oObject, ctipText, nIcon, title)。nIcon 取值 0 无图标1=信息, 2=警告,3=错误
*m: track && 跟踪鼠标显示提示
*m: updatetrackwindow && 更新窗口信息
*p: cstruct && 上次结构值
*p: htrack && 跟踪提示的窗口句柄
*p: labsolute && 不自动调整信息的弹出位置(始终在下方显示?)
*p: lalwaystip && 鼠标位于控件上方时,是否总是显示提示(没用)。
*p: lballoon && 是否使用气泡提示
*p: lcentertip && 是否在控件的中间显示提示
*p: lclose && 关闭按钮
*p: lnofade && 非淡入淡出,滑出效果?
*p: naddress && 地址集合的数组下标
*p: naddx && 提示位置的 X 轴增量值。
*p: naddy && 提示位置 的Y 轴增量值
*p: nalign && 指明当 Show 中未说明时提示出现在控件的什么位置。1=上左2= 上中3=上右4=中左5=中中6=中右7=下左8=下中9=下右。默认值 7.
*p: nbackcolor && 提示信息的背景色
*p: ndelaytime && 提示自动消失的毫秒数,如果为 0 则不会消失。
*p: ndwstyle && 初始或者默认的提示窗口的 DwStyle 如果此值小于0则默认为 TTS_NOPREFIX + TTS_USEVISUALSTYLE
*p: nforecolor && 提示信息的前景色
*p: nmaxwidth && 提示信息的最大宽度
*p: oreftimer && 指向隐藏提示的计时器
*p: paddress && 内存地址
*a: aaddress[1,0]
*</DefinedPropArrayMethod>
HIDDEN aaddress,htrack,naddress,oreftimer,paddress
*<PropValue>
cstruct =
Height = 17
htrack = 0
labsolute = .F.
lalwaystip = .F.
lballoon = .F.
lcentertip = .F.
lclose = .F.
lnofade = .F.
naddress = 0
naddx = 0
naddy = 0
nalign = 7
Name = "tooltipex"
nbackcolor = -1
ndelaytime = 4000
ndwstyle = -1
nforecolor = -1
nmaxwidth = -1
oreftimer =
paddress = 0
Visible = .F.
Width = 65
*</PropValue>
ADD OBJECT 'Label1' AS label WITH ;
AutoSize = .T., ;
BackStyle = 0, ;
Caption = "ToolTipEx", ;
Height = 16, ;
Left = 6, ;
Name = "Label1", ;
Top = 2
*< END OBJECT: BaseClass="label" />
PROCEDURE about
**********************************************
***
*** ToolTipEx Class
*** Version
***
*** Author by: 施凌峰
*** Create date: 2008.06.15
*** Last update:
***
**********************************************
***
*** 如果它确实对您有所帮助,并且你也非常喜欢,您可以通过网上汇款略表您的心意,让我们在辛劳制作中得到欣慰, 谢谢。
***
*** 银行账号
*** 中国工商银行: 9558 8014 0810 5404 077
*** 中国建设银行: 4367 4218 3350 0044 031
*** 开户人:施凌峰
***
*** 赞助金额不限,只作对我们努力的认可。
***
*** 我们的网址http://xykjsoft.blog.163.com
***
***
*** 测试环境Windows 2000、Windows XP
*** 开发语言Vfp9 SP2
***
*!* typedef struct tagTOOLINFO{
*!* UINT cbSize; 4
*!* UINT uFlags; 4
*!* HWND hwnd; 4
*!* UINT_PTR uId; 4
*!* RECT Rect; 4*4
*!* HINSTANCE hinst; 4
*!* LPTSTR lpszText; 4
*!* #if (_WIN32_IE >= 0x0300)
*!* LPARAM lParam; 4
*!* #endif
*!* #if (_WIN32_WINNT >= 0x0501)
*!* void *lpReserved; 4
*!* #endif
*!* #if (_WIN32_WINNT >= 0x0600)
*!* HBITMAP hbmp; 4
*!* #endif
*!* } TOOLINFO, NEAR *PTOOLINFO, *LPTOOLINFO
ENDPROC
PROCEDURE addcontrol && 对一个表单控件添加提示
LPARAMETERS toObject, tcTipText
*!* Private loForm, lpRect, lnLeft, lnTop, lnRight, lnBottom, lhInst, lcTipText, lpszText, lnFlags
*!* Local loForm, lpRect, lnLeft, lnTop, lnRight, lnBottom, lhInst, lcTipText, lpszText, lnFlags
*!* If This.hTip = 0
*!* Return .F.
*!* EndIf
*!* If Not VarType(m.toObject) = "O" Or IsNull(m.toObject)
*!* Messagebox("请指定一个目标对象!", 16, "ToolTipEx.AddControl")
*!* Return .F.
*!* EndIf
*!* loForm = toObject
*!* Do While Not InList(Upper(loForm.BaseClass), "FORM", "TOOLBAR")
*!* loForm = loForm.Parent
*!* EndDo
*!* *!* lpPoint = Replicate(Chr(0), POINT_SIZE)
*!* *!* ClientToScreen(ThisForm.Hwnd, @lpPoint)
*!* lpRect = Replicate(Chr(0), RECT_SIZE)
*!* GetClientRect(loForm.hWnd, @lpRect)
*!* lnLeft = CToBin(Substr(lpRect, 1, 4), "4rs") + ObjToClient(toObject, 2)
*!* lnTop = CToBin(Substr(lpRect, 5, 4), "4rs") + ObjToClient(toObject, 1)
*!* lnRight = lnLeft + toObject.Width
*!* lnBottom = lnTop + toObject.Height
*!* * lpRect = BinToC(m.lnLeft, "4rs") + BinToC(m.lnTop, "4rs") + BinToC(m.lnRight, "4rs") + BinToC(m.lnBottom, "4rs")
*!* lpRect = BinToC(0, "4rs") + BinToC(0, "4rs") + BinToC(ThisForm.Width, "4rs") + BinToC(ThisForm.Height, "4rs")
*!* ? lnLeft, lnTop, lnRight, lnBottom
*!* * lpRect = BinToC(0, "4rs") + BinToC(0, "4rs") + BinToC(ThisForm.Width, "4rs") + BinToC(ThisForm.Height, "4rs")
*!* lhInst = GetWindowLong(loForm.hWnd, GWL_HINSTANCE)
*!* lcTipText = Iif(VarType(m.tcTipText) = "C", m.tcTipText, toObject.ToolTipText)
*!* lpszText = LocalAlloc(LPTR, Len(m.lcTipText))
*!* CopyStr2MemA(m.lpszText, m.lcTipText, Len(m.lcTipText))
*!* *-- 记录内存地址,退出时销毁
*!* This.nAddress = This.nAddress + 1
*!* Dimension This.aAddress[This.nAddress]
*!* This.aAddress[This.nAddress] = m.lpszText
*!* * TTF_SUBCLASS 默认子类
*!* * TTF_TRACK 指明位置
*!* * TTF_TRANSPARENT 透明?
*!* *-- 结构
*!* lnFlags = TTF_IDISHWND + TTF_SUBCLASS + TTF_TRANSPARENT
*!* lnFlags = Iif(This.lCenterTip, lnFlags + TTF_CENTERTIP , m.lnFlags)
*!* lcStruct = BinToC(m.lnFlags, "4rs") ; && uFlags
*!* + BinToC(loForm.hWnd, "4rs") ; && hWnd
*!* + BinToC(loForm.hWnd, "4rs") ; && uId
*!* + BinToC(m.lhInst, "4rs") ; && hInst
*!* + m.lpRect ; && Rect
*!* + BinToC(m.lpszText, "4rs") ; && lpszText
*!* + BinToC(0, "4rs") && lPara
*!* lcStruct = BinToC(Len(m.lcStruct) + 4, "4rs") + m.lcStruct
*!* ? SendMessage2c(This.hTip, TTM_ADDTOOLA, 0, m.lcStruct)
ENDPROC
PROCEDURE addmessage && 添加一个对象信息,在获得焦点与失去焦点时,显示信息。
LPARAMETERS toObject, tcTipText, tnIcon, tcTitle
If VarType(m.toObject) = "O" And Not IsNull(m.toObject)
toObject.AddProperty("cTipText", Iif(VarType(m.tcTipText) = "C", m.tcTipText, ""))
toObject.AddProperty("nIcon", Iif(VarType(m.tnIcon) = "N", m.tnIcon, 0))
toObject.AddProperty("cTitle", Iif(VarType(m.tcTitle) = "C", m.tcTitle, ""))
BindEvent(toObject, "GotFocus", This, "b_GotFocus")
BindEvent(toObject, "LostFocus", This, "Hide")
EndIf
ENDPROC
PROCEDURE b_gotfocus && 绑定到对象 GotFocus 事件
Private loObject, laArray
Local loObject, laArray
Dimension laArray[1]
AEvents(laArray, 0)
This.Show(laArray[1] ;
, Iif(Empty(laArray[1].cTipText), laArray[1].ToolTipText, laArray[1].cTipText) ;
, laArray[1].nIcon, laArray[1].cTitle)
ENDPROC
PROCEDURE createtrackwindow
Private lnStyle, lnDwStyle
Local lnStyle, lnDwStyle
If This.hTrack <> 0
DestroyWindow(This.hTrack)
EndIf
* WS_EX_TOPMOST + WS_EX_LAYERED + WS_POPUP
lnStyle = WS_EX_TOPMOST
* lnStyle = Bitxor(Bitor(lnStyle, WS_BORDER), WS_BORDER)
lnDwStyle = Iif(This.nDwStyle >= 0, This.nDwStyle, TTS_NOPREFIX + TTS_USEVISUALSTYLE)
lnDwStyle = Iif(This.lClose, BitOr(m.lnDwStyle, TTS_CLOSE), m.lnDwStyle)
lnDwStyle = Iif(This.lNoFade, BitOr(m.lnDwStyle, TTS_NOFADE), m.lnDwStyle)
lnDwStyle = Iif(This.lBalloon, BitOr(m.lnDwStyle, TTS_BALLOON), m.lnDwStyle)
lnDwStyle = Iif(This.lAlwaysTip, BitOr(m.lnDwStyle, TTS_ALWAYSTIP), m.lnDwStyle)
lnDwStyle = Bitxor(Bitor(m.lnDwStyle, WS_BORDER), WS_BORDER)
This.hTrack = CreateWindowEx ;
(m.lnStyle, "tooltips_class32", "", m.lnDwStyle, ;
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, 0, 0)
If This.hTrack = 0
Messagebox("创建提示信息窗口失败!", 16, "ToolTipEx.CreateTrackWindow")
Return
EndIf
If This.nForeColor > -1
SendMessage2n(This.hTrack, TTM_SETTIPTEXTCOLOR, This.nForeColor, 0)
EndIf
If This.nBackColor > -1
SendMessage2n(This.hTrack, TTM_SETTIPBKCOLOR, This.nBackColor, 0)
EndIf
* TTM_SETTIPBKCOLOR
ENDPROC
PROCEDURE declare_dlls
Declare Long SendMessage In "User32" As SendMessage2n ;
Long hWnd, Long nMsg, Long wParam, Long lParam
Declare Long SendMessage In "User32" As SendMessage2c;
Long hWnd, Long nMsg, Long wParam, String lParam
Declare Long GetWindowLong In "User32" ;
Long hWnd, Long nIndex
Declare Integer LocalAlloc In "Kernel32" ;
Long uFlags, Long dwBytes
Declare Integer LocalFree In "Kernel32" ;
Long hlocMem
Declare Integer RtlMoveMemory In "Kernel32" As CopyStr2MemA ;
Long lpDest, String @lpSource, Long nLength
Declare Long CreateWindowEx In "User32" ;
Long dwExStyle, String lpClassName, String lpWindowName, ;
Long dwStyle, Long x, Long y, Long nWidth, Long nHeight, ;
Long hWndParent, Long hMenu, Long hInstance, Long lpParam
Declare Long DestroyWindow In "User32" ;
Long hWnd
Declare Long ClientToScreen In "User32" ;
Long hWnd, String @lpPoint
Declare Long GetClientRect In "User32" ;
Long hWnd, String @lpRect
Declare Long GetWindowLong In "User32" ;
Long hWnd, Long nIndex
Declare Long SetWindowLong In "User32" ;
Long hWnd, Long nIndex, Long dwNewLong
Declare Integer GetCursorPos In "User32" ;
String @lpPoint
* InitCommonControls() library "comctl32.dll"
* InitCommonControls
ENDPROC
PROCEDURE Destroy
If This.hTrack <> 0
DestroyWindow(This.hTrack)
EndIf
If This.pAddress <> 0
LocalFree(This.pAddress)
EndIf
UnBindEvent(_Screen, "Moved", This, "Hide")
ENDPROC
PROCEDURE getstructvalue
LPARAMETERS tcText
Private lcTipText, lnFlags, lsStruct
Local lcTipText, lnFlags, lsStruct
*-- 分配内存空间
lcTipText = Strtran(Transform(m.tcText), "\n", CRLF) + Chr(0)
If This.pAddress <> 0
LocalFree(This.pAddress)
EndIf
This.pAddress = LocalAlloc(LPTR, Len(m.lcTipText))
CopyStr2MemA(This.pAddress, m.lcTipText, Len(m.lcTipText))
* TTF_SUBCLASS 默认子类
* TTF_TRACK 指明位置
* TTF_TRANSPARENT 透明?
*-- 结构
lnFlags = TTF_SUBCLASS + TTF_TRANSPARENT + TTF_TRACK
lnFlags = Iif(This.lAbsolute, BitOr(m.lnFlags, TTF_ABSOLUTE), m.lnFlags)
lnFlags = Iif(This.lCenterTip, BitOr(lnFlags, TTF_CENTERTIP), m.lnFlags)
lsStruct = BinToC(m.lnFlags, "4rs") ; && uFlags
+ BinToC(ThisForm.Hwnd, "4rs") ; && hWnd
+ BinToC(0, "4rs") ; && uId
+ BinToC(0, "4rs") ; && hInst
+ Replicate(Chr(0), 16) ; && Rect
+ BinToC(This.pAddress, "4rs") ; && lpszText
+ BinToC(0, "4rs") && lPara
lsStruct = BinToC(Len(m.lsStruct) + 4, "4rs") + m.lsStruct
Return m.lsStruct
ENDPROC
PROCEDURE hide && 通过设置 Visible 属性为“假”(.F.),隐藏一个表单,表单集或工具栏。
LPARAMETERS tnHwnd, tnMsg, tnWparam, tnLparam
If This.hTrack <> 0
DestroyWindow(This.hTrack)
EndIf
This.hTrack = 0
This.oRefTimer.Enabled = .F.
This.cStruct = "HIDE"
UnBindEvent(ThisForm.Hwnd, WM_LBUTTONDOWN)
*!* If PCount() = 4
*!* Declare Integer CallWindowProc In "User32" ;
*!* Long lpPrevWndFunc, Long nhWnd, Long uMsg, Long wParam, Long lParam
*!*
*!* Return CallWindowProc(This.pProc, tnHwnd, tnMsg, tnWparam, tnLparam)
*!* EndIf
ENDPROC
PROCEDURE Init
If Not PemStatus(_Screen, This.Class, 5)
This.Declare_Dlls()
_Screen.AddProperty(This.Class, .T.)
EndIf
This.CreateTrackWindow()
If This.hTrack <> 0
This.oRefTimer = NewObject("Timer")
This.oRefTimer.Interval = This.nDelayTime
BindEvent(This.oRefTimer, "Timer", This, "Hide")
BindEvent(ThisForm, "Moved", This, "Hide", 1)
BindEvent(ThisForm, "Resize", This, "Hide", 1)
BindEvent(_Screen, "Moved", This, "Hide", 1)
EndIf
ENDPROC
PROCEDURE show && 在指定控件上显示控件提示。Show(oObject, ctipText, nIcon, title)。nIcon 取值 0 无图标1=信息, 2=警告,3=错误
LPARAMETERS toObject, tcTipText, tnIcon, tcTitle, tnAlign
Private loForm, lsPoint, lnLeft, lnTop, lnParam, lcTipText, lsStruct, lnAlign
Local loForm, lsPoint, lnLeft, lnTop, lnParam, lcTipText, lsStruct, lnAlign
This.CreateTrackWindow()
If This.hTrack = 0
Return
EndIf
lnAlign = Iif(VarType(m.tnAlign) = "N", m.tnAlign, This.nAlign)
lsPoint = Replicate(Chr(0), POINT_SIZE)
If VarType(m.toObject) = "O" And Not IsNull(m.toObject)
loForm = m.toObject
Do While Not InList(Upper(loForm.BaseClass), "FORM", "TOOLBAR")
loForm = loForm.Parent
EndDo
*-- 确定控件相对于表单的坐标
ClientToScreen(loForm.Hwnd, @lsPoint)
lnLeft = CToBin(Left(m.lsPoint, 4), "4rs") + ObjToClient(m.toObject, 2)
lnTop = CToBin(Right(m.lsPoint, 4), "4rs") + ObjToClient(m.toObject, 1)
Do Case
*-- 水平居上
Case m.lnAlign = 1 && 左
*--
Case m.lnAlign = 2 && 中
lnLeft = m.lnLeft + ObjToClient(m.toObject, 3) / 2
Case m.lnAlign = 3 && 右
lnLeft = m.lnLeft + ObjToClient(m.toObject, 3)
*-- 水平居中
Case m.lnAlign = 4 && 左
lnTop = m.lnTop + toObject.Height / 2
Case m.lnAlign = 5 && 中
lnTop = m.lnTop + toObject.Height / 2
lnLeft = m.lnLeft + ObjToClient(m.toObject, 3) / 2
Case m.lnAlign = 6 && 右
lnTop = m.lnTop + toObject.Height / 2
lnLeft = m.lnLeft + ObjToClient(m.toObject, 3)
*-- 水平居下
Case m.lnAlign = 7 && 左
lnTop = m.lnTop + toObject.Height
Case m.lnAlign = 8 && 中
lnTop = m.lnTop + toObject.Height
lnLeft = m.lnLeft + ObjToClient(m.toObject, 3) / 2
Case m.lnAlign = 9 && 右
lnTop = m.lnTop + toObject.Height
lnLeft = m.lnLeft + ObjToClient(m.toObject, 3)
EndCase
lnLeft = m.lnLeft + This.nAddX
lnTop = m.lnTop + This.nAddY
Else
*-- 取鼠标当前位置
GetCursorPos(@m.lsPoint)
lnLeft = CToBin(Left(m.lsPoint, DWORD_SIZE), "4rs")
lnTop = CToBin(Right(m.lsPoint, DWORD_SIZE), "4rs")
EndIf
lnParam = lnLeft + BitLShift(m.lnTop, 16)
*-- 获取信息结构
lsStruct = This.GetStructValue(m.tcTipText)
SendMessage2n(This.hTrack, TTM_TRACKPOSITION, 0, m.lnParam)
SendMessage2c(This.hTrack, TTM_ADDTOOLA, 0, m.lsStruct)
If VarType(m.tnIcon) = "N" And VarType(m.tcTitle) = "C"
SendMessage2c(This.hTrack, TTM_SETTITLEA, m.tnIcon, m.tcTitle)
EndIf
SendMessage2c(This.hTrack, TTM_TRACKACTIVATE, 1, m.lsStruct)
BindEvent(ThisForm.Hwnd, WM_LBUTTONDOWN, This, "Hide")
This.oRefTimer.Enabled = .T.
ENDPROC
PROCEDURE track && 跟踪鼠标显示提示
LPARAMETERS tcTipText, tnIcon, tcTitle
Private lsPoint, lnLeft, lnTop, lnParam, lnFlags, lsStruct
Local lsPoint, lnLeft, lnTop, lnParam, lnFlags, lsStruct
If This.cStruct == "HIDE"
This.cStruct = ""
Return
EndIf
If This.hTrack = 0
This.CreateTrackWindow()
EndIf
If This.hTrack = 0
Return
EndIf
*-- 取鼠标当前位置
lsPoint = Replicate(Chr(0), POINT_SIZE)
GetCursorPos(@m.lsPoint)
lnLeft = CToBin(Left(m.lsPoint, DWORD_SIZE), "4rs") + 16
lnTop = CToBin(Right(m.lsPoint, DWORD_SIZE), "4rs") + 16
lnParam = lnLeft + BitLShift(m.lnTop, 16)
lsStruct = This.GetStructValue(m.tcTipText)
If VarType(m.tnIcon) = "N" And VarType(m.tcTitle) = "C"
SendMessage2c(This.hTrack, TTM_SETTITLEA, m.tnIcon, m.tcTitle)
Else
SendMessage2c(This.hTrack, TTM_SETTITLEA, 0, "")
EndIf
SendMessage2n(This.hTrack, TTM_TRACKPOSITION, 0, m.lnParam)
If Not Empty(This.cStruct)
SendMessage2c(This.hTrack, TTM_UPDATETIPTEXTA, 0, m.lsStruct)
Else
SendMessage2c(This.hTrack, TTM_ADDTOOLA, 0, m.lsStruct)
SendMessage2c(This.hTrack, TTM_TRACKACTIVATE, 1, m.lsStruct)
EndIf
This.oRefTimer.Enabled = .T.
This.cStruct = m.lsStruct
ENDPROC
HIDDEN PROCEDURE updatetrackwindow && 更新窗口信息
Local lnStyle
lnStyle = GetWindowLong(This.hTrack, GWL_STYLE)
SetWindowLong(This.hTrack, GWL_STYLE, m.lnStyle)
*!* IF ( This.CloseButton )
*!* m.nStyle = BITOR( m.nStyle, TTS_CLOSE )
*!* ELSE
*!* m.nStyle = BITAND( m.nStyle, BITNOT( TTS_CLOSE ))
*!* ENDIF
ENDPROC
PROCEDURE Label1.Init
Return .F.
ENDPROC
ENDDEFINE