*-------------------------------------------------------------------------------------------------------------------------------------------------------- * (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="" /> * *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 && 指向另一个预定义菜单菜单 * * 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 * ENDDEFINE DEFINE CLASS iconcollection AS custom && 图标句柄收集 *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> #INCLUDE "win32api.h" * *m: declare_dlls *m: getimage && 返回图形文件在内存中的句柄 *m: loadimage *m: newimage && 新定义一个图形文件名柄 * * Name = "iconcollection" Width = 17 * 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霾说� *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> #INCLUDE "win32api.h" * *m: about && 1O于盻A� *m: add && I砑硬说睢PARAMETERS tcParentKey, tcKey, tcTitle, tcCommand, tcPicture, tvEnabled, tnAddFlag *m: additem && I砑硬说�: 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楹I框或罝表框縊糭諨的内E荨� *m: createcontext && 创建与指I蛄鞳桓霾说チ� *m: createmenus *m: declare_dlls *m: destroymenus && IU菜单 *m: drawgradualrect && 指定莖域后覣指定袿色绘制。可选水平或�1直。 *m: draw_bar && 画侧边Io *m: draw_image && 画图I� *m: draw_selected && 绘制选定 *m: draw_separator *m: draw_text && 画文盻莖 *m: gethalfcolor && E×缴涞陌肷� *m: gethwnd && 获E〈翱赺浔� *m: get_rect_num && 从 Rect 结11諨返籓E怠�1付说O址参E蚪�1槐4娴降O址参ED。 *m: get_rect_str && 传递 Left, Top, Right, Bottom 四个参E祷O RECT 结11样的字符串。 *m: inititems && 3oE蓟_A改緿臝� *m: modifymenus && D_改菜单的 Enabled 状I� *m: newitem && 获E桓鯝改慷訧� *m: setmessage && 设諥菜单I钭碔珹窱酔_D臝ⅲ诙_参指物A聿说畹腄蚝牛珽盓1覣最近I砑拥牟说ァ� *m: setpicture && 设諥菜单I畹耐计诙_参指物A聿说頓蚝牛珽盓1覣最近I砑拥牟说ァ� *m: show && I訣_菜单在指定的 x,y 護标外,E�1粗付ǎ诘鼻癊蟊晡恢AI訣_。 *m: showby && 指定表单的�3个对I螅诟A对I蟮腎路降_3霾说ァ� *m: transparentblta && See win32Api TransparentBlt *p: classlibraryroot && A嘣璄悸穇禔� *p: hmenu && 主菜单的菜单_浔� *p: lownerdraw && E欠馝1覣自绘菜单,E�1� .F. 忽略所覦绘制E鬌浴⒉蜤鑫曜� Windows 菜单。 *p: lselectedenabled && (读D�) 只对 Enabled = .T. 的菜单I罱oDD绘制选定框 *p: lshareicons && (读定) E欠馝1覣1睮硗急昕猓珽�1酥滴� .T.,图标库会被O恢北�3郑琌员蹵庵O复读E 绱酥滴� .F.,则为A扛鯡礎唇ǖザA图标索O狻�(调E宰碔肷栉� .F.) *p: nbarfillcolor1 && E瞪獻�3洳说ゲ啾逜富騉呓ケ銭保柚AI�3渖騉呓ケ涞钠dE忌� *p: nbarfillcolor2 && E瞪獻�3洳说ゲ啾逜富騉呓ケ銭保柚AI�3渖騉呓ケ涞慕酔o色。 *p: nbarstyle && (读D�) 侧边A秆鵈健�0=蝊,1=E瞪獻�3�,2=水平1�,3=�1直1� *p: nbarwidth && (读D�) 侧边A缚矶E *p: nhwnd && 窗口_浔� *p: nimageleft && (读D�) 图标莖域的左边_� *p: nitemheight && (读D�) 最D〔说罡叨E,当值D∮诘E于 0 E保远_计薬。 *p: nitemwidth && (读D�) 最D〔说羁矶E,当此值D∮诘E于 0 E保� 自禵计薬。 *p: nmaxlen && 记录最3の谋_的3ざE,在内存分配礝址覣到此值。 *p: nmenubackcolor && (读D�) 设諥菜单�3_吧酥礑∮�0E盓低3设諥 *p: nmenuheight && (只读) 主I訣_菜单高禘 *p: nmenuwidth && (只读) 主I訣_菜单宽禘 *p: nreturn && 返籓值方E健�0=索O�,1 = cKey, 3 = A改课谋_, 4=对I� *p: nselectedbackcolor && (读D�) 当前选定I畹谋3_吧酥礑∮� 0 E盓低3设諥 *p: nselectedbordercolor && (读D�) 选定_OD蔚谋呖蛏酥礑∮� 0 E盓低3设諥 *p: nselectedforecolor && (读D�) 选定I畹那癬吧酥礑∮� 0 E盓低3设諥。 *p: nselectedimagestyle && (读D�) 选定图标的样E� 0=蝊, 1=�1芼,2=单禔选定 *p: nselectedroundx && (读D�) 椭圆_OD窝《ǹ虻脑步强矶E *p: nselectedroundy && (读D�) 椭圆_OD窝《ǹ虻脑步歉叨E *p: nselectedstyle && 选諨Io风格 0=标准�3_�, 1=_OD慰蜓《ǹ�,2=椭圆选定框,3=�1芼选定框,4=凹I卵《ǹ� *p: ntextleft && 设諥文盻莖的左边_� *p: ntextmargin && 文盻莖内文盻的的薿給值 *p: ocollections && A改孔芗_篒,CreateItems E敝窱蚋鞲鯝改俊4唇ㄍ�3珊驣U。 *p: oitems && 菜单A改考_篒,保存各个A改慷訧� *p: oreficons && 指I蛲急闑O糭器 *p: pproc && 給3I指O� * HIDDEN nhwnd,nmaxlen,nmenuheight,nmenuwidth,ocollections,oitems,oreficons,pproc * 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 * PROCEDURE about && 1O于盻A� ********************************************** *** *** 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砑硬说睢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砑硬说�: 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楹I框或罝表框縊糭諨的内E荨� This.DestroyMenus() This.oItems = NewObject("Collection") This.oCollections = NewObject("Collection") ENDPROC PROCEDURE createcontext && 创建与指I蛄鞳桓霾说チ� 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 && 指定莖域后覣指定袿色绘制。可选水平或�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� 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×缴涞陌肷� 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〈翱赺浔� 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怠�1付说O址参E蚪�1槐4娴降O址参E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祷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改緿臝� *-- 计算最大字符长度 *-- 计算各个栏目所需宽高 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� 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桓鯝改慷訧� 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臝ⅲ诙_参指物A聿说畹腄蚝牛珽盓1覣最近I砑拥牟说ァ� 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畹耐计诙_参指物A聿说頓蚝牛珽盓1覣最近I砑拥牟说ァ� 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�1粗付ǎ诘鼻癊蟊晡恢AI訣_。 Lparameters tnX, tnY, tlAbsolute, tuFlags *!* 所覦预定O宓目O制菜单I睿∣瞋虴荌低3菜单)的ID号監D氪笥� 0xF000。E�13个应覣3ID騉狪砑覫低3菜单, *!* 其I低3菜单的 ID 号監D隓∮贔000。” *-- tnX x 座标 *-- tnY y 座标 *-- tlAbsolute 此座标E欠馹o对護标 *-- tuFlags 自定O� 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О埽�", 16, "PopMenu.ShowBy") Return Null Endif If Pcount() >= 2 *-- 在指定護标礯3� lnX = Iif(Vartype(m.tnX) = "N", m.tnX, 0) lnY = Iif(Vartype(m.tnY) = "N", m.tnY, 0) If Not m.tlAbsolute *-- 此座标E荌喽云聊恢� 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即唇� *** If This.hMenu <> 0 *-- 菜单己创建,D_改菜单I钅贓� This.ModifyMenus() Else *-- 菜单未创建,创建菜单 This.oCollections = Null This.oCollections = Newobject("Collection") This.hMenu = CreatePopupMenu() This.CreateMenus(This.oCollections, This.hMenu) Endif * This.BindEvents(.T.) *-- 礯3龇紼� 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� Return loItem.nIndex Case This.nReturn = 1 *-- cKey Return loItem.cKey Case This.nReturn = 2 *-- A改课谋_ Return loItem.cTitle Case This.nReturn = 3 *-- 对I� Return m.loItem Otherwise Return Null Endcase Else Return Null Endif ENDPROC PROCEDURE showby && 指定表单的�3个对I螅诟A对I蟮腎路降_3霾说ァ� 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" * *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] * HIDDEN aaddress,htrack,naddress,oreftimer,paddress * 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 * 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