chargrid.dpr

像windows字符映射表

program CharGrid;

//------------------------------------------------------------------------------
//Project:         CharGrid.exe
//Version:         1.0
//Last Updated:    5-FEB-2003
//Compiler:        Delphi 6
//Author:          Angus Johnson, [e-mail]
//Copyright:       ?2003 Angus Johnson

//Note:            'Character Grid' was written as an example of how to write
//                 Delphi applications without the VCL - it requires quite a bit
//                 more work but the final application size can be much smaller.
//------------------------------------------------------------------------------

uses
  Windows,
  Messages,
  Types,
  CommDlg,
  SysUtils,
  Richedit, 
  CommCtrl;

{$R main.res}

const
  cm_GetFont = 1001;
  cm_UseHex = 1002;
  cm_ClearClip = 1003;
  cm_HelpAbout = 1010;
  fontFace = 'Arial';
  custWinClass = 'ajCUSTOM'; //see custom control on DIALOG_1 resource
var
  YellowBrush: HBrush;
  SilverPen: HPen;
  mainDlg, customCtrl, statusbarCtrl, accel: THandle;
  RichEdLib: THandle;
  mainIcon: HIcon;
  UseHexValues: boolean;
  custFont, mainFont: HFont;
  numHeight: integer;
  cellSizeMin,         //minimum grid cell size based on font used to display Nums.
  cellSizeCust: TSize; //cell size based on the user selected (custom) font
  selectedCell: TPoint;
  clipbrdChars: string;

//------------------------------------------------------------------------------
//------------------------------------------------------------------------------

//ChangeFont: replaces 'theFont' with a new font (also returns a LOGFONT structure)
function ChangeFont(dlgOwner: THandle; var theFont: HFont; out LogFont: TLogFont): boolean;
var
  ChooseFontRec: TChooseFont;
begin
  FillChar(ChooseFontRec,SizeOf(ChooseFontRec),0);
  with ChooseFontRec do
  begin
    lStructSize := SizeOf(ChooseFontRec);
    lpLogFont := @LogFont;
    Flags := CF_SCREENFONTS or CF_LIMITSIZE;
    if theFont > 0 then
    begin
      GetObject(theFont, SizeOf(LogFont), @LogFont);
      Flags := Flags or CF_INITTOLOGFONTSTRUCT;
    end;
    nSizeMin := 8;
    nSizeMax := 20;
    hWndOwner := dlgOwner;
  end;
  result := ChooseFont(ChooseFontRec);
  if not result then exit;
  if theFont > 0 then
    DeleteObject(theFont);
  theFont := CreateFontIndirect(LogFont);
end;
//------------------------------------------------------------------------------

//GetCellSize: calculates the cell size for the grid based on supplied font
function GetCellSize(font: HFont; MinimumSize: TSize): TSize;
var
  dc: HDC;
  oldFont: HFont;
  i: integer;
  c: char;
  tmp: TSize;
begin
  dc := GetDC(mainDlg);
  try
    oldFont := SelectObject(dc, font);
    if numHeight = 0 then
      GetTextExtentPoint32(dc,'255',3,result)
    else
    begin
      GetTextExtentPoint32(dc,'W',1,result);
      for i := 33 to 255 do
      begin
        c := char(i);
        GetTextExtentPoint32(dc,@c,1,tmp);
        if tmp.cx > result.cx then result.cx := tmp.cx;
      end;
    end;
    inc(result.cx,5); //add space either side
    if numHeight = 0 then //height of numbers only
      numHeight := result.cy;
      inc(result.cy, numHeight + 8); //room for char & number & space between
    SelectObject(dc, oldFont);
  finally
    ReleaseDC(mainDlg,dc);
  end;
  if result.cx < MinimumSize.cx then result.cx := MinimumSize.cx;
  if result.cy < MinimumSize.cy then result.cy := MinimumSize.cy;
end;
//------------------------------------------------------------------------------

procedure CenterWindow(Window: HWnd);
var
  r: TRect;
  l,t,w,h: integer;
begin
  //get the window dimensions...
  GetWindowRect(Window,r);
  w := r.Right-r.Left;
  h := r.Bottom-r.Top;
  //get the desktop workarea (excluding the taskbar)...
  SystemParametersInfo(SPI_GETWORKAREA,0,@r,0);
  //center the window...
  l := r.Left + (r.Right-r.Left - w) div 2;
  t := r.Top + (r.Bottom -r.Top - h) div 2;
  SetWindowPos(Window,0,l,t,0,0, SWP_NOSIZE or SWP_NOZORDER);
end;
//---------------------------------------------------------------------

//ResizeAll: needed whenever the custom font changes
procedure ResizeAll;
var
  tmpSize: TSize;
  custWidth, custHeight: integer;
  rec, mainRec, sbarRec: TRect;
begin
  custWidth := cellSizeCust.cx * 32 + 4;
  custHeight := cellSizeCust.cy * 7 + 4;
  SetWindowPos(customCtrl, 0, 0, 0, custWidth, custHeight,
    SWP_NOMOVE or SWP_NOZORDER or SWP_DRAWFRAME);

  GetClientRect(mainDlg,mainRec);
  GetWindowRect(mainDlg,rec);
  //get difference between WindowRec & ClientRec ...
  tmpSize.cx := (rec.Right - rec.Left) - (mainRec.Right - mainRec.Left);
  tmpSize.cy := (rec.Bottom - rec.Top) - (mainRec.Bottom - mainRec.Top);
  GetWindowRect(statusbarCtrl,sbarRec);
  inc(tmpSize.cy, (sbarRec.Bottom - sbarRec.Top));
  SetWindowPos(mainDlg, 0, 0, 0, custWidth+ tmpSize.cx, custHeight+ tmpSize.cy,
    SWP_NOMOVE or SWP_NOZORDER or SWP_DRAWFRAME);
  //finally reposition statusbarCtrl ...
  SetWindowPos(statusbarCtrl, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_DRAWFRAME);
  CenterWindow(mainDlg);
end;
//---------------------------------------------------------------------

function CellPtToRect(cell: TPoint): TRect;
begin
  result := Rect(cell.X*cellSizeCust.cx, cell.Y*cellSizeCust.cy,
      (cell.X+1)*cellSizeCust.cx, (cell.Y+1)*cellSizeCust.cy);
end;
//---------------------------------------------------------------------

function PtInRectToCellPt(pt: TPoint): TPoint;
begin
  result := Point(pt.X div cellSizeCust.cx, pt.Y div cellSizeCust.cy);
end;
//---------------------------------------------------------------------

procedure DrawRect(dc: HDC; Rec: TRect);
begin
  MoveToEx(dc, rec.Left, rec.Top, nil);
  LineTo(dc, rec.Right, rec.Top);
  LineTo(dc, rec.Right, rec.Bottom);
  LineTo(dc, rec.Left, rec.Bottom);
  LineTo(dc, rec.Left, rec.Top);
end;
//---------------------------------------------------------------------

procedure CustCtrlDraw(custCtrlHdl: THandle; dc: HDC);
var
  oldFont: HFont;
  oldPen: HPen;
  rec: TRect;
  i,j: integer;
  c: char;
  s: string;
begin
  GetClientRect(custCtrlHdl,rec);
  //draw silver line grid, numbers & chars ...
  oldPen := SelectObject(dc, silverPen);
  oldFont := SelectObject(dc, mainFont);
  try
    DrawRect(dc, rec);
    for i := 0 to 31 do
      for j := 0 to 6 do //NB: first 32 chars are unprintable so they're skipped
      begin
        rec := CellPtToRect(Point(i,j));
        //yellow out the selected cell
        if (SelectedCell.X = i) and (SelectedCell.Y = j) then
        begin
          FillRect(dc,rec,yellowBrush);
          SetBkColor(dc, RGB(255,255,0));
        end else
        begin
          FillRect(dc,rec,GetStockObject(WHITE_BRUSH));
          SetBkColor(dc, RGB(255,255,255));
        end;
        if UseHexValues then
          s := inttohex(((j+1)*32)+i,2)else
          s := inttostr(((j+1)*32)+i);
        TextOut(dc, rec.Left+2,
          rec.Bottom - numHeight -1, pchar(s), length(s));
        SelectObject(dc, custFont);
        c := chr(((j+1)*32)+i);
        TextOut(dc, rec.Left+3, rec.Top+3, @c, 1);
        SelectObject(dc, mainFont);
        DrawRect(dc,rec);
      end;
  finally
    SelectObject(dc, oldPen);
    SelectObject(dc, oldFont);
  end;
end;
//---------------------------------------------------------------------

procedure AddCurrentSelToClipbrd;
var
  Data: THandle;
  DataPtr: Pointer;
  s: string;
  len: integer;
begin
  clipbrdChars := clipbrdChars + chr((selectedCell.y+1)*32 + selectedCell.x);
  len := length(clipbrdChars);
  s := ' Clipboard Characters: '+ clipbrdChars;
  if not OpenClipboard(0) then exit;
  try
    EmptyClipboard;
    Data := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE or GMEM_ZEROINIT, len);
    try
      DataPtr := GlobalLock(Data);
      try
        Move(clipbrdChars[1], DataPtr^, len);
        SetClipboardData(CF_TEXT, Data);
      finally
        GlobalUnlock(Data);
      end;
    except
      GlobalFree(Data);
      raise;
    end;
    Sendmessage(statusbarCtrl,WM_SETTEXT,0,integer(pchar(s)));
  finally
    CloseClipboard;
  end;
end;
//------------------------------------------------------------------------------

procedure ClearClipbrd;
var
  s: string;
begin
  if not OpenClipboard(0) then exit;
  s := ' Clipboard Characters: ';
  EmptyClipboard;
  clipbrdChars := '';
  Sendmessage(statusbarCtrl,WM_SETTEXT,0,integer(pchar(s)));
  CloseClipboard;
end;
//------------------------------------------------------------------------------

//CustCtrlProc: The custom control which displays chars in a grid
function CustCtrlProc(hWnd, uMsg, wParam, lParam: cardinal): Integer; stdcall;