chargrid.dpr

像windows字符映射表

var
  ps: TPaintStruct;
  dc: HDC;
begin
  case uMsg of
    WM_KEYDOWN:
      case wParam of
        VK_RETURN: AddCurrentSelToClipbrd;
        VK_LEFT:
          if selectedCell.X > 0 then
          begin
            dec(selectedCell.X);
            invalidateRect(hWnd,nil,true); //force repaint
          end;
        VK_RIGHT:
          if selectedCell.X < 31 then
          begin
            inc(selectedCell.X);
            invalidateRect(hWnd,nil,true); //force repaint
          end;
        VK_DOWN:
          if selectedCell.y < 6 then
          begin
            inc(selectedCell.Y);
            invalidateRect(hWnd,nil,true); //force repaint
          end;
        VK_UP:
          if selectedCell.y > 0 then
          begin
            dec(selectedCell.Y);
            invalidateRect(hWnd,nil,true); //force repaint
          end;
      end;
    WM_SETFONT: invalidateRect(hWnd,nil,true); //force repaint
    WM_ERASEBKGND: //avoids flicker (each cell in grid is fully redrawn anyway)
      begin
        result := 1;
        exit;
      end;
    WM_LBUTTONDOWN:
      begin
        selectedCell := PtInRectToCellPt(Point(loword(lParam),hiword(lParam)));
        invalidateRect(hWnd,nil,true); //force repaint
      end;
    WM_LBUTTONDBLCLK: AddCurrentSelToClipbrd;
    WM_PAINT:
      begin
        dc := BeginPaint(hWnd,ps);
        try
          CustCtrlDraw(hWnd, dc);
        finally
	  EndPaint(hWnd,ps);
        end;
        result := 0;
        exit;
      end;
  end;
  result := DefWindowProc( hWnd, uMsg, wParam, lParam);
end;
//------------------------------------------------------------------------------

type
  //used to stream in RTF text into the Help About dialog.
  PCookie = ^TCookie;
  TCookie = record
    Chars: PChar;
    Pos  : integer;
    Len  : integer;
  end;

//see the EM_STREAMIN Richedit message in Win32.Hlp for more info...
function RichEdStreamIn(dwCookie: Longint;
  pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall;
var
  Cookie: PCookie;
begin
  Cookie := PCookie(dwCookie);
  pcb := Cookie.Len - Cookie.Pos;
  if pcb > cb then pcb := cb;
  try
    with Cookie^ do
    begin
      Move(Chars[Pos], pbBuff^, pcb);
      inc(Pos,pcb);
    end;
    result := 0; //OK
  except
    result := 1; //error
  end;
end;
//------------------------------------------------------------------------------

//HelpProc: Help About Dialog procedure
function HelpProc(Dialog: HWnd; AMessage, WParam: LongInt; LParam: Longint): Bool; stdcall;
var
  es: TEDITSTREAM;
  Cookie: TCookie;
  ResHdl: THandle;
  ResGlob: THandle;
  ResText: pChar;
  RichEdHdl: THandle;
begin
  result := true; //ie assume handled
  case AMessage of
    WM_INITDIALOG:         
      begin
        //load the RTF text from the resource into the Richedit control...
        ResHdl := FindResource(hInstance,'#1','RTF');
        ResGlob := LoadResource(hInstance,ResHdl);
        ResText := LockResource(ResGlob);
        Cookie.Chars := ResText;
        Cookie.Pos := 0;
        Cookie.Len := strlen(ResText);
        es.dwCookie := LongInt(@Cookie);
        es.pfnCallBack := @RichEdStreamIn;
        es.dwError := 0;
        RichEdHdl := GetDlgItem(Dialog, 12);
        SendMessage(RichEdHdl, EM_STREAMIN, SF_RTF, longint(@es));
        //change the Richedit background color ...
        SendMessage(RichEdHdl, EM_SETBKGNDCOLOR, 0, $00f0f0f0);
      end;
    WM_COMMAND:
      case LoWord(WParam) of
        IDOK, IDCANCEL: EndDialog(Dialog, 1); //modal dialogs only
      end;
    else result := False; //not handled
  end;
end;
//------------------------------------------------------------------------------

//MainProc: Main dialog procedure
function MainProc(Dialog, AMessage, wParam, lParam: cardinal): Integer; stdcall;
var
  lf: TLogFont;
  s: string;
begin
  result := 1; //assume message is handled
  case AMessage of
    WM_INITDIALOG:
      begin
        //set the application icon...
        mainIcon := LoadIcon( hInstance, 'MAINICON');
        SetClassLong( Dialog, GCL_HICON, mainIcon);
      end;
    WM_DESTROY:
      begin
        result := 0;
        PostQuitMessage(0); //used by modeless dialogs only
      end;
    WM_COMMAND:
      case LoWord(WParam) of
        IDCANCEL: DestroyWindow(mainDlg);
        cm_GetFont: //select display font
          if ChangeFont(Dialog, custFont, lf) then
          begin
            s := 'Character Grid - '+ lf.lfFaceName;
            Sendmessage(Dialog,WM_SETTEXT,0,integer(pchar(s)));
            cellSizeCust := GetCellSize(custFont, cellSizeMin);
            ResizeAll;
          end;
        cm_UseHex: //toggle Hex/Decimal values
          begin
            UseHexValues := not UseHexValues;
            if UseHexValues then
              CheckMenuItem(GetSubMenu(GetMenu(Dialog),0),1002,MF_BYCOMMAND or MF_CHECKED) else
              CheckMenuItem(GetSubMenu(GetMenu(Dialog),0),1002,MF_BYCOMMAND or MF_UNCHECKED);
            invalidateRect(customCtrl,nil,true);
          end;
        cm_ClearClip: ClearClipbrd;
        cm_HelpAbout: //create a MODAL Help About dialog ...
          DialogBox(hInstance, MAKEINTRESOURCE(2), Dialog , @HelpProc);
      end;
    else result := 0; //not handled
  end;
end;                                     
//---------------------------------------------------------------------

procedure Initialize;
var
  WinClass: TWndClass;
  LogBrush: TLogBrush;
  LogPen: TLogPen;
begin
  initCommonControls; //needed for the "Statusbar" on mainDlg
  RichEdLib := LoadLibrary('Riched32.dll'); //needed for the Help dialog

  //Register the custom control class (grid) in the dialog resource ...
  FillChar(WinClass,Sizeof(WinClass),0);
  with WinClass do
  begin
    style              := CS_VREDRAW + CS_HREDRAW + CS_DBLCLKS;
    lpfnWndProc        := @CustCtrlProc;
    hInstance          := sysInit.hInstance;
    hbrBackground      := GetSysColorBrush(COLOR_WINDOW);
    lpszClassname      := custWinClass;
    hCursor            := LoadCursor(0, IDC_ARROW);
  end;
  RegisterClass(WinClass);

  //create our MODELESS main dialog ...
  mainDlg := CreateDialog( hInstance, MAKEINTRESOURCE(1), 0, @MainProc);
  if mainDlg = 0 then
  begin
    //if something went wrong, cleanup and quit ...
    UnregisterClass(custWinClass, hInstance);
    FreeLibrary(RichEdLib);
    halt(1);
  end;

  //create the 2 fonts ...
  mainFont := CreateFont(-9, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET,
                      OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
                      DEFAULT_PITCH or FF_DONTCARE, pchar(fontFace));
  custFont := CreateFont(-14, 0, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET,
                      OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
                      DEFAULT_PITCH or FF_DONTCARE, pchar(fontFace));

  //get the minimum cell size based on number font ...
  cellSizeMin := GetCellSize(mainFont, cellSizeMin);
  
  cellSizeCust := GetCellSize(custFont, cellSizeMin);
  selectedCell := Point(0,0);

  customCtrl := GetDlgItem(mainDlg, 10);
  statusbarCtrl := GetDlgItem(mainDlg, 11);
  ResizeAll;

  //Since the main window is resized & repositioned on startup
  //(which would cause unnecessary movement if the dialog was visible),
  //the WS_VISIBLE flag is not set in the resource dialog. Therefore ...
  ShowWindow(mainDlg,SW_SHOW);
  
  setfocus(customCtrl);

  accel := LoadAccelerators(hInstance, MAKEINTRESOURCE(1));

  //Create a yellow brush ...
  LogBrush.lbStyle := BS_SOLID;
  LogBrush.lbColor := RGB(255,255,0);
  LogBrush.lbHatch := 0;
  YellowBrush := CreateBrushIndirect(LogBrush);

  //Create a silver pen ...
  LogPen.lopnStyle := PS_SOLID;
  LogPen.lopnWidth.X := 1;
  LogPen.lopnColor := $00c0c0c0;
  SilverPen := CreatePenIndirect(LogPen);
end;
{--------------------------------------------------------------------------}

procedure CleanUp;
begin
  DeleteObject(mainFont);
  DeleteObject(custFont);
  DestroyIcon(mainIcon);
  DeleteObject(YellowBrush);
  DeleteObject(SilverPen);
  UnregisterClass(custWinClass, hInstance);
  FreeLibrary(RichEdLib);
end;
{--------------------------------------------------------------------------}

var
  msg: TMsg;
begin
  //HERE'S WHERE IT'S ALL HAPPENS ...
  Initialize;
  //Message Loop ...
  while GetMessage(msg, 0, 0, 0) do
    if TranslateAccelerator(mainDlg, accel, msg) = 0 then
    begin
      TranslateMessage(msg);
      DispatchMessage(msg);
    end;
  CleanUp;
end.