legend.pas

这一系列是我平时收集的pascal深入核心编程

unit Legend;

interface

uses Windows, Messages;

const
 // Legend控件类名
  WC_LEGEND = 'Legend';

 // 自定控件风格
  LS_SMALLBOX = $00000000;
  LS_BIGBOX = $00000001;
  LS_BOXBORDER = $00000002;

 // 自定控件消息 ~~

 // Purpose: 设置填充画刷, (注: 该画刷应该由调用者建立和清除)
 // wParam: HBRUSH - 新的画刷句柄
 // lParam: 略
 // Return: 略
  LM_SETBOXBRUSH = (WM_USER + 0);

 // Purpose: 取得填充画刷
 // wParam: 略
 // lParam: 略
 // Return: HBRUSH - 当前画刷句柄
  LM_GETBOXBRUSH = (WM_USER + 1);

 // Purpose: 设置背景颜色
 // wParam: 略
 // lParam: COLORREF - 新的背景颜色
 // Return: 略
  LM_SETBKCOLOR = (WM_USER + 2);

 // Purpose: 取得背景颜色
 // wParam: 略
 // lParam: 略
 // Return: COLORREF - 当前背景颜色
  LM_GETBKCOLOR = (WM_USER + 3);

 // Purpose: 设置文字颜色
 // wParam: 略
 // lParam: COLORREF - 新的文字颜色
 // Return: 略
  LM_SETTEXTCOLOR = (WM_USER + 4);

 // Purpose: 取得文字颜色
 // wParam: 略
 // lParam: 略
 // Return: COLORREF - 当前文字颜色
  LM_GETTEXTCOLOR = (WM_USER + 5);

 // 对控件消息的简单包装
procedure Legend_SetBoxBrush(hWnd: HWND; hbrNew: HBRUSH);
function Legend_GetBoxBrush(hWnd: HWND): HBRUSH;
procedure Legend_SetBkColor(hWnd: HWND; crNew: COLORREF);
function Legend_GetBkColor(hWnd: HWND): COLORREF;
procedure Legend_SetTextColor(hWnd: HWND; crNew: COLORREF);
function Legend_GetTextColor(hWnd: HWND): COLORREF;

  // 注册/注销控件窗体类
function Legend_RegisterClass(hInst: THandle; fGlobalClass: BOOL): ATOM; stdcall;
function Legend_UnregisterClass(hInst: THandle): BOOL; stdcall

implementation

type
 // 窗体实例额外内存结构
  T_Legend_WndExtraBytes = packed record
    hfont: HFONT; // 文字字体
    hbr: HBRUSH;  // 填充画刷
    crBk, crText: COLORREF; // 背景颜色, 文字颜色
  end;

 // 设置填充画刷
procedure Legend_SetBoxBrush(hWnd: HWND; hbrNew: HBRUSH);
begin
  SendMessage(hWnd, LM_SETBOXBRUSH, hbrNew, 0);
end;

 // 取得填充画刷
function Legend_GetBoxBrush(hWnd: HWND): HBRUSH;
begin
  Result := SendMessage(hWnd, LM_GETBOXBRUSH, 0, 0);
end;

 // 设置背景颜色
procedure Legend_SetBkColor(hWnd: HWND; crNew: COLORREF);
begin
  SendMessage(hWnd, LM_SETBKCOLOR, 0, crNew);
end;

 // 取得背景颜色
function Legend_GetBkColor(hWnd: HWND): COLORREF;
begin
  Result := SendMessage(hWnd, LM_GETBKCOLOR, 0, 0);
end;

 // 设置文字颜色
procedure Legend_SetTextColor(hWnd: HWND; crNew: COLORREF);
begin
  SendMessage(hWnd, LM_SETTEXTCOLOR, 0, crNew);
end;

 // 取得文字颜色
function Legend_GetTextColor(hWnd: HWND): COLORREF;
begin
  Result := SendMessage(hWnd, LM_GETTEXTCOLOR, 0, 0);
end;

 // Legend控件WM_CREATE处理
function Legend_OnCreate(hWnd: HWND; PtCreateStruct: PCreateStruct): BOOL;
var
  crBk: COLORREF;
  hWndParent: LongWord; // HWND
  hWndDc: HDC;
  hbr: HBRUSH;
  lb: TLogBrush;
begin
  hWndParent := GetParent(hWnd);
  
 // 采用默认的字体
  SendMessage(hWnd, WM_SETFONT, 0, 0);

 // 采用父窗体背景
  if (GetClassWord(hWndParent, GCW_ATOM) = 32770) then
  begin
    hWndDc := GetDC(hWndParent);
    hbr := SendMessage(hWndParent, WM_CTLCOLORDLG, hWndDc, hWndParent);
    ReleaseDC(hWndParent, hWndDc);

    GetObject(hbr, SizeOf(TLogBrush), @lb);
    crBk := lb.lbColor;
  end else
    crBk := GetSysColor(COLOR_WINDOW);

 // 初始化控件属性
  Legend_SetBkColor(hWnd, crBk);
  Legend_SetBoxBrush(hWnd, GetStockObject(DKGRAY_BRUSH));
  Legend_SetTextColor(hWnd, GetSysColor(COLOR_WINDOWTEXT));

  Result := TRUE;
end;

 // Legend控件WM_SETFONT处理
procedure Legend_OnSetFont(hWnd: HWND; hFontNew: HFONT; fReDraw: BOOL); stdcall;
begin
  SetWindowLong(hWnd, 0, hFontNew);  
  if (fRedraw) then InvalidateRect(hWnd, nil, FALSE);
end;

 // Legend控件WM_GETFONT处理
function Legend_OnGetFont(hWnd: HWND): HFONT; stdcall;
begin
  Result := GetWindowLong(hWnd, 0);
end;

 // Legend控件WM_PAINT处理
procedure Legend_OnPaint(hWnd: HWND);
var
  rcClient, rcBox: TRect;
  ps: TPaintStruct;
  hfont, hfontOriginal: LongWord; // HFONT
  hbrOriginal, hbrFrame: HBRUSH;
  size: TSize;
  psz: PChar;
  nTextLength, nBoxSide, nShrinkBox: Integer;
begin
 // 开始绘制
  BeginPaint(hWnd, ps);

 // 背景/文字颜色
  SetBkColor(ps.hdc, Legend_GetBkColor(hWnd));
  SetTextColor(ps.hdc, Legend_GetTextColor(hWnd));

 // 计算绘制范围
  GetClientRect(hWnd, rcClient); // 控件尺寸
  nBoxSide := rcClient.Bottom;
  SetRect(rcBox, 0, 0, nBoxSide, nBoxSide);
  if (GetWindowLong(hWnd, GWL_STYLE) and LS_BIGBOX) <> 0 then
    nShrinkBox := - nBoxSide div 6  // 缩小6分之一
  else
    nShrinkBox := - nBoxSide div 4; // 缩小4分之一
  InflateRect(rcBox, nShrinkBox, nShrinkBox); // 缩小

 // 需要绘制边框
  if (GetWindowLong(hWnd, GWL_STYLE) and LS_BOXBORDER) <> 0 then
  begin
    hbrFrame := CreateSolidBrush(GetTextColor(ps.hdc));
    FrameRect(ps.hdc, rcBox, hbrFrame);
    DeleteObject(hbrFrame);
    InflateRect(rcBox, -1, -1); // 缩小
  end;

 // 使用特定画刷填充
  SetBrushOrgEx(ps.hdc, 0, 0, nil);
  hbrOriginal := SelectObject(ps.hdc, Legend_GetBoxBrush(hWnd));
  PatBlt(ps.hdc, rcBox.Left, rcBox.Top,
    rcBox.Right - rcBox.Left, rcBox.Bottom - rcBox.Top, PATCOPY);
  SelectObject(ps.hdc, hbrOriginal);

 // 恢复完整绘制范围
  if (GetWindowLong(hWnd, GWL_STYLE) and LS_BOXBORDER) <> 0 then InflateRect(rcBox, 1, 1);

 // 排除在剪裁区域外
  ExcludeClipRect(ps.hdc, rcBox.Left, rcBox.Top, rcBox.Right, rcBox.Bottom);

 // 取出控件窗体文字
  nTextLength := GetWindowTextLength(hWnd);
  GetMem(psz, nTextLength + 1);
  GetWindowText(hWnd, psz, nTextLength + 1);

 // 绘制控件窗体文字          
  hfont := SendMessage(hWnd, WM_GETFONT, 0, 0);
  if (hfont <> 0) then
    hfontOriginal := SelectObject(ps.hdc, hfont)
  else
    hfontOriginal := 0;

  GetTextExtentPoint32(ps.hdc, psz, nTextLength, Size);
  ExtTextOut(ps.hdc, nBoxSide + nBoxSide div 3, (rcClient.Bottom - Size.cy) div 2,
    ETO_OPAQUE or ETO_CLIPPED, @rcClient, psz, nTextLength, nil);

  if (hfont <> 0) then
    SelectObject(ps.hdc, hfontOriginal);

 // 释放内存 
  FreeMem(psz);

 // 完成绘制
  EndPaint(hWnd, ps);
end;

 // Legend控件WM_SETTEXT处理
procedure Legend_OnSetText(hWnd: HWND; lpszText: PChar);
begin
 // 这里我们应该调用DefWindowProc()而不是SetWindowText()
 // 因为后者会发送一个WM_SETTEXT消息, 那么程序将进入无限
 // 循环调用. 实际上,DefWindowProc()会去实际设置窗体文字
  DefWindowProc(hWnd, WM_SETTEXT, 0, LPARAM(lpszText));

 // 迫使控件重绘(为了显示出新的窗体文字)
  InvalidateRect(hWnd, nil, FALSE);
end;

 // Legend控件LM_SETBOXBRUSH处理
procedure Legend_OnSetBoxBrush(hWnd: HWND; hbrNew: HBRUSH); stdcall;
begin
 // 检测是否有效画刷
  if (GetObjectType(hbrNew) <> OBJ_BRUSH) then Exit;

 // 保存新的画刷句柄
  SetWindowLong(hWnd, SizeOf(HFONT), hbrNew);

 // 迫使控件重绘(为了显示出新的画刷样式)
  InvalidateRect(hWnd, nil, FALSE);
end;

 // Legend控件LM_GETBOXBRUSH处理
function Legend_OnGetBoxBrush(hWnd: HWND): HBRUSH; stdcall;
begin
 // 取出当前画刷句柄
  Result := GetWindowLong(hWnd, SizeOf(HFONT));
end;

 // Legend控件LM_SETBKCOLOR处理
procedure Legend_OnSetBkColor(hWnd: HWND; crBkNew: COLORREF); stdcall;
begin
 // 保存新的背景颜色
  SetWindowLong(hWnd, SizeOf(HFONT) + SizeOf(HBRUSH), crBkNew);

 // 迫使控件重绘(为了显示出新的背景颜色)
  InvalidateRect(hWnd, nil, TRUE); // 麻子注: 此处 TRUE 有意义吗 ??
end;

 // Legend控件LM_GETBKCOLOR处理
function Legend_OnGetBkColor(hWnd: HWND): COLORREF; stdcall;
begin
 // 取出当前背景颜色
  Result := GetWindowLong(hWnd, SizeOf(HFONT) + SizeOf(HBRUSH));
end;

 // Legend控件LM_SETTEXTCOLOR处理
procedure Legend_OnSetTextColor(hWnd: HWND; crTextNew: COLORREF); stdcall;
begin
 // 保存新的文字颜色
  SetWindowLong(hWnd, SizeOf(HFONT) + SizeOf(HBRUSH) + SizeOf(COLORREF), crTextNew);

 // 迫使控件重绘(为了显示出新的文字颜色)  
  InvalidateRect(hWnd, nil, TRUE);
end;

 // Legend控件LM_GETTEXTCOLOR处理
function Legend_OnGetTextColor(hWnd: HWND): COLORREF; stdcall;
begin
 // 取出当前文字颜色
  Result := GetWindowLong(hWnd, SizeOf(HFONT) + SizeOf(HBRUSH) + SizeOf(COLORREF));
end;

 // Legend控件消息处理过程
function Legend_WndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
  Result := 0;

  case (uMsg) of
   // 标准窗体消息
    WM_CREATE:
      begin
        if Legend_OnCreate(hWnd, PCreateStruct(lParam)) = FALSE then Result := -1;
      end;

    WM_PAINT:
      begin
        Legend_OnPaint(hWnd);
      end;

    WM_SETTEXT:
      begin
        Legend_OnSetText(hWnd, PChar(lParam));
      end;

    WM_SETFONT:
      begin
        Legend_OnSetFont(hWnd, wParam, BOOL(lParam));
      end;

    WM_GETFONT:
      begin
        Result := Legend_OnGetFont(hWnd);
      end;

   // 控件自定消息
    LM_SETBOXBRUSH:
      begin
        Legend_OnSetBoxBrush(hWnd, wParam);
      end;

    LM_GETBOXBRUSH:
      begin
        Result := Legend_OnGetBoxBrush(hWnd);
      end;

    LM_SETBKCOLOR:
      begin
        Legend_OnSetBkColor(hWnd, lParam);
      end;

    LM_GETBKCOLOR:
      begin
        Result := Legend_OnGetBkColor(hWnd);
      end;

    LM_SETTEXTCOLOR:
      begin
        Legend_OnSetTextColor(hWnd, lParam);
      end;

    LM_GETTEXTCOLOR:
      begin
        Result := Legend_OnGetTextColor(hWnd);
      end;

    else Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
  end;
end;

 // 注册Legend控件
function Legend_RegisterClass(hInst: THandle; fGlobalClass: BOOL): ATOM; stdcall;
var
  wc: TWndClassEx;
begin
  ZeroMemory(@wc, SizeOf(wc));

  wc.cbSize := SizeOf(wc);
  wc.style := CS_HREDRAW or CS_VREDRAW;
  wc.lpfnWndProc := @Legend_WndProc;
  wc.cbWndExtra := SizeOf(T_Legend_WndExtraBytes);
  wc.hInstance := hInst;
  wc.hCursor := LoadCursor(0, IDC_ARROW);
  wc.lpszClassName := WC_LEGEND;

  if (fGlobalClass) then
    wc.style := wc.style or CS_GLOBALCLASS;

  Result := RegisterClassEx(wc);
end;

 // 注销Legend控件
function Legend_UnregisterClass(hInst: THandle): BOOL; stdcall
begin
  Result := UnregisterClass(WC_LEGEND, hInst);
end;

end.