[分享]菜单自绘去除边框

sanguomi 2009-07-01 11:48:11
加精
方法比较麻烦,不是很可取,大家有更好的方法可以一起讨论 ,从系统COPY一个MEMO单元出来,屏蔽了TPOPULIST.WNDPROC里的WM_DRAWITEM, WM_MEASUREITEM消息处理,使用的使TMainMenu,TPopupMenu 的Image属性不为空,随便加个IAMGELIST


var
CBrgColor: TColor = $6D8F38;
CSelectColor: TColor = $7eb237;
CTextColor: TColor = clWhite;
CSelectTextColor: TColor = clHighlight;
MenuOldWndProc: Pointer;

function GetMenuItem(ID: Integer): TMenuItem;
var
I: Integer;
begin
for I := 0 to PopupList.Count - 1 do
begin
Result := TPopupMenu(PopupList.Items[I]).FindItem(ID, fkCommand);
if Result <> nil then
Exit;
end;
end;

procedure MenuMeasureItem(P: PMeasureItemStruct);
var
Item: TMenuItem;
R: TRect;
Text: string;
DC: HDC;
SaveIndex: Integer;
begin
Item := GetMenuItem(P^.itemID);
if Item.Caption = cLineCaption then
begin
P^.itemHeight := 5;
P^.itemWidth := 5;
end;

Inc(p^.itemHeight, 3);

if Item.ShortCut <> 0 then
Text := Concat(Item.Caption, ShortCutToText(Item.ShortCut))
else
Text := Item.Caption;

DC := GetWindowDC(PopupList.Window);
try
SaveIndex := SaveDC(DC);
try
SelectObject(DC, Screen.MenuFont.Handle);
ZeroMemory(@R, SizeOf(TRect));
DrawText(DC, PChar(Text), -1, R, DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT);
Inc(P^.itemWidth, R.Right - R.Left + 20);
if Item.ShortCut <> 0 then
Inc(P^.itemWidth, 10);
finally
RestoreDC(DC, SaveIndex);
end;
finally
ReleaseDC(PopupList.Window, DC);
end;
end;

procedure MenuItemDraw(P: PDrawItemStruct);
procedure DrawPolyline(const DC: HDC; const Points: array of TPoint);
type
PPoints = ^TPoints;
TPoints = array[0..0] of TPoint;
begin
Windows.Polyline(DC, PPoints(@Points)^, High(Points) + 1);
end;
var
SaveIndex: Integer;
Item: TMenuItem;
R: TRect;
T: Integer;
begin
with P^ do
begin
SaveIndex := SaveDC(hDC);
try
R := rcItem;
SelectObject(hDC, Screen.MenuFont.Handle);
if ODS_SELECTED and itemState = ODS_SELECTED then
begin
SetDCBrushColor(hDC, CSelectColor);
SetTextColor(hDC, CSelectTextColor);
end
else
begin
SetDCBrushColor(hDC, CBrgColor);
SetTextColor(hDC, ColorToRGB(clMenuText));
end;
FillRect(hDC, R, GetStockObject(DC_BRUSH));
Item := GetMenuItem(P^.itemID);
if Item.Caption = cLineCaption then
begin
SelectObject(hDC, GetStockObject(DC_PEN));
SetDCPenColor(hDC, $8F8F8F);
T := R.Top + (R.Bottom - R.Top) shr 1;
DrawPolyline(hDC, [Point(1, T), Point(R.Right - 1, T)]);
SetDCPenColor(hDC, $CFCFCF);
DrawPolyline(hDC, [Point(1, T + 1), Point(R.Right - 1, T + 1)]);
end
else
begin
SetBkMode(hDC, TRANSPARENT);
if ODS_CHECKED and itemState = ODS_CHECKED then
with TBitmap.Create do
try
Handle := LoadBitmap(0, PChar(OBM_CHECK));
TransparentBlt(hDC, R.Left + (16 - Width) shr 1 + 1, R.Top + (R.Bottom - R.Top - Height) shr 1,
Width, Height, Canvas.Handle, 0, 0, Width, Height, $FFFFFF);
finally
Free;
end;
R.Left := R.Left + 20;
Inc(R.Top);
SetTextColor(HDC, CTextColor);
DrawText(hDC, PChar(Item.Caption), -1, R, DT_VCENTER or DT_SINGLELINE);
if Item.ShortCut <> 0 then
begin
R.Right := R.Right - 4;
DrawText(hDC, PChar(ShortCutToText(Item.ShortCut)), -1, R, DT_RIGHT or DT_VCENTER or DT_SINGLELINE);
end;
end;
finally
RestoreDC(hDC, SaveIndex);
end;
end;
end;

function MenuWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
R: TRect;
Pen: HPEN;
SaveIndex: Integer;
DC: HDC;
begin
case Msg of
WM_PRINT:
begin
Result := CallWindowProc(MenuOldWndProc, hWnd, WM_PRINT, wParam, lParam);
// if lParam and PRF_NONCLIENT = PRF_NONCLIENT then
// begin
// if GetDCBrushColor(wParam) <> CBrgColor then Exit;
Pen := CreatePen(PS_SOLID, 4, CBrgColor);
try
SaveIndex := SaveDC(wParam);
try
SelectObject(wParam, GetStockObject(NULL_BRUSH));
SelectObject(wParam, Pen);
GetWindowRect(hWnd, R);
OffsetRect(R, -R.Left, -R.Top);
Rectangle(wParam, 1, 1, R.Right, R.Bottom);
finally
RestoreDC(wParam, SaveIndex);
end;
finally
DeleteObject(Pen);
end;
// end;
end;
//WM_PAINT: ;
WM_NCPAINT:
begin
CallWindowProc(MenuOldWndProc, hWnd, Msg, wParam, lParam);
// DC := GetDCEx(hwnd, wParam, DCX_WINDOW or DCX_INTERSECTRGN);
DC := GetWindowDC(hWnd);
try
Pen := CreatePen(PS_SOLID, 4, CBrgColor);
try
SelectObject(DC, GetStockObject(NULL_BRUSH));
SelectObject(DC, Pen);
GetWindowRect(hWnd, R);
OffsetRect(R, -R.Left, -R.Top);
Rectangle(DC, 1, 1, R.Right, R.Bottom);
finally
DeleteObject(Pen);
end;
finally
ReleaseDC(hWnd, DC);
end;

end;
else
Result := CallWindowProc(MenuOldWndProc, hWnd, Msg, wParam, lParam);
end;
end;

function WindowsHook(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall;
var
pStruct: PCWPStruct;
ClassName: array[0..63] of Char;
lastWndProc: Pointer;
begin
pStruct := PCWPStruct(lParam);
if (Code = HC_ACTION) and ((pStruct^.message <> WM_CREATE) or (pStruct^.message <> $01E2)) and
(GetClassName(pStruct^.hwnd, @ClassName[0], SizeOf(ClassName)) = 6) and
(StrPas(@ClassName[0]) = '#32768') then
begin
lastWndProc := Pointer(GetWindowLong(pStruct^.hwnd, GWL_WNDPROC));
if lastWndProc <> @MenuWndProc then
begin
SetWindowLong(pStruct^.hwnd, GWL_WNDPROC, Integer(@MenuWndProc));
MenuOldWndProc := lastWndProc;

end;
end;
Result := CallNextHookEx(WH_CALLWNDPROC, Code, wParam, lParam);
end;

initialization
SetWindowsHookEx(WH_CALLWNDPROC, WindowsHook, hInstance, GetCurrentThreadId);



...全文
511 22 打赏 收藏 转发到动态 举报
写回复
用AI写文章
22 条回复
切换为时间正序
请发表友善的回复…
发表回复
sanguomi 2009-07-01
  • 打赏
  • 举报
回复
[Quote=引用 5 楼 constantine 的回复:]
去除边框?自己不画上去难道还有边框。
另外lz的做法确实比较麻烦,继承修改代码,然后在使用的unit里面将菜单对应的类名指向新类应该更好吧。
[/Quote]

自己DrawItem画里确实有个边框
嗷嗷叫的老马 2009-07-01
  • 打赏
  • 举报
回复
路过.....
constantine 2009-07-01
  • 打赏
  • 举报
回复
去除边框?自己不画上去难道还有边框。
另外lz的做法确实比较麻烦,继承修改代码,然后在使用的unit里面将菜单对应的类名指向新类应该更好吧。
sanguomi 2009-07-01
  • 打赏
  • 举报
回复
[Quote=引用 3 楼 xzhifei 的回复:]
N年前的XPMENU就实现了啊
[/Quote]

我去找来看下
xzhifei 2009-07-01
  • 打赏
  • 举报
回复
N年前的XPMENU就实现了啊
starluck 2009-07-01
  • 打赏
  • 举报
回复
學習。
sanguomi 2009-07-01
  • 打赏
  • 举报
回复
上边打错,从系统COPY一个Menus单元出来,
lhy 2009-07-01
  • 打赏
  • 举报
回复
这么复杂,不理它不就省事了。
hemiya 2009-07-01
  • 打赏
  • 举报
回复
学习
超维电脑科技 2009-07-01
  • 打赏
  • 举报
回复
收藏学习
wuhuwy 2009-07-01
  • 打赏
  • 举报
回复
顶!好东西!
xysyzj 2009-07-01
  • 打赏
  • 举报
回复
顶,谢谢分享!
yongy1985 2009-07-01
  • 打赏
  • 举报
回复
谢谢分享!
nettman 2009-07-01
  • 打赏
  • 举报
回复
Mark!
zhangpan2010 2009-07-01
  • 打赏
  • 举报
回复
路过 学习一下
火龙岛主 2009-07-01
  • 打赏
  • 举报
回复

ice_beauty1 2009-07-01
  • 打赏
  • 举报
回复
偶错了,原来是delphi,没学过
ice_beauty1 2009-07-01
  • 打赏
  • 举报
回复
VB代码啊,以前用过
这几段代码貌似并不简单(⊙o⊙)?
liuhuan992 2009-07-01
  • 打赏
  • 举报
回复
个人认为这样太累了,
占个11楼,
对楼主仰望之!
liangpei2008 2009-07-01
  • 打赏
  • 举报
回复
晚上一定要学习一下
加载更多回复(2)

1,183

社区成员

发帖
与我相关
我的任务
社区描述
Delphi Windows SDK/API
社区管理员
  • Windows SDK/API社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧