inssymbolrvfrm.pas

一个基于不需引擎的文件管理系统,使用了许多界面比较好的控件

unit InsSymbolRVFrm;

interface

{$I RV_Defs.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, StdCtrls, ExtCtrls, TB2Dock, TB2ToolWindow, TBX,
  TBXDkPanels, TB2ExtItems, TBXExtItems, TB2Item, SpTBXItem, TB2Toolbar;

const
  CM_DENYSUBCLASSING = CM_BASE + 2000;

type
  TFontCharset = 0..255;

  TZoomPanel = class (TPanel)
  private
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure CMDenySubclassing(var Msg: TMessage); message CM_DENYSUBCLASSING;
  protected
    procedure Paint; override;
  public
    DefWidth: Integer;
    FontName: String;
    FontCharset: TFontCharset;
    Text: String;
    TextW: WideString;
  end;

  TfrmRVInsertSymbol = class(TForm)
    TBXToolWindow1: TTBXToolWindow;
    Label1: TLabel;
    dg: TDrawGrid;
    btnOk: TTBXButton;
    TBXButton2: TTBXButton;
    TBXToolbar1: TTBXToolbar;
    SpTBXLabelItem1: TSpTBXLabelItem;
    SpTBXRightAlignSpacerItem1: TSpTBXRightAlignSpacerItem;
    SpTBXLabelItem2: TSpTBXLabelItem;
    cmbCharset1: TTBXComboBoxItem;
    cmbFont1: TTBXComboBoxItem;
    procedure FormCreate(Sender: TObject);
    procedure dgDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
      State: TGridDrawState);
    procedure dgSelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure dgTopLeftChanged(Sender: TObject);
    procedure cmbCharset1AcceptText(Sender: TObject; var NewText: String;
      var Accept: Boolean);
    procedure cmbFont1AcceptText(Sender: TObject; var NewText: String;
      var Accept: Boolean);
    procedure cmbFont1ItemClick(Sender: TObject);
    procedure cmbCharset1ItemClick(Sender: TObject);
  private
    { Private declarations }
    FontName: String;
    FontCharset: TFontCharset;
    function GetCharsets(Index: Integer): TFontCharset;
  public
    { Public declarations }
    Panel: TZoomPanel;
    procedure Init(Char: Word; const AFontName: String; ACharset: TFontCharset);
    procedure GetInfo(var Char: Word; var AFontName: String; var ACharset: TFontCharset);
    procedure SetOptions(AllowUnicode, AllowANSI: Boolean);
    procedure Build;
    property Charsets[Index: Integer]: TFontCharset read GetCharsets;
  end;


implementation

{$R *.dfm}
function EnumFontCharsets(var EnumLogFont: TEnumLogFontEx;
  PTextMetric: PNewTextMetricEx; FontType: Integer; Data: LPARAM): Integer;
  export; stdcall;
var s: String;
    l,cs: Integer;
begin
  Result := 1;
  cs := EnumLogFont.elfLogFont.lfCharSet;
  if cs<>MAC_CHARSET then begin
    l := StrLen(EnumLogFont.elfScript);
    SetLength(s,l);
    Move(EnumLogFont.elfScript, PChar(s)^,  l);
    for l := 0 to TTBXComboBoxItem(Data).Strings.Count-1 do begin
      if Integer(TTBXComboBoxItem(Data).Strings.Objects[l])=cs then
        exit;
      if AnsiCompareText(TTBXComboBoxItem(Data).Strings[l],s)>0 then begin
        TTBXComboBoxItem(Data).Strings.InsertObject(l,s,TObject(cs));
        exit;
      end;
    end;
    TTBXComboBoxItem(Data).Strings.AddObject(s, TObject(cs));
  end;
end;

procedure TfrmRVInsertSymbol.FormCreate(Sender: TObject);
begin
  dg.Height := 198;
  dg.DefaultColWidth := (dg.Width-4-GetSystemMetrics(SM_CXVSCROLL)) div (dg.ColCount+1);
  dg.DefaultRowHeight := (dg.ClientHeight) div (dg.RowCount+1);
  dg.Height := dg.RowCount*(dg.DefaultRowHeight+1)+(dg.Height-dg.ClientHeight);

  Panel := TZoomPanel.Create(Self);
  Panel.Parent := Self;
  Panel.DefWidth := dg.DefaultColWidth*2;
  Panel.SetBounds(100,100,dg.DefaultColWidth*2,dg.DefaultRowHeight*2);

  cmbFont1.Strings.Assign(Screen.Fonts);

  Init(32+28*5+11, 'Symbol', SYMBOL_CHARSET);
end;

procedure TfrmRVInsertSymbol.Init(Char: Word; const AFontName: String;
  ACharset: TFontCharset);
var idx: Integer;
begin
  cmbFont1.ItemIndex := cmbFont1.Strings.IndexOf(AFontName);
  if cmbFont1.ItemIndex<0 then
    cmbFont1.ItemIndex := 0;
  cmbFont1ItemClick(nil);
  idx := cmbCharset1.Strings.IndexOfObject(TObject(ACharset));
  if idx>=0 then
  begin
    cmbCharset1.ItemIndex := idx;
    cmbCharset1ItemClick(nil);
  end;
  if Char=0 then
    Char := 32;
  dec(Char, 32);
  dg.Col := Char mod 28;
  dg.Row := Char div 28;
end;

procedure TfrmRVInsertSymbol.SetOptions(AllowUnicode, AllowANSI: Boolean);
begin
  cmbCharset1ItemClick(nil);
end;

procedure TfrmRVInsertSymbol.GetInfo(var Char: Word;
  var AFontName: String; var ACharset: TFontCharset);
begin
  Char := 32+dg.Row*dg.ColCount+dg.Col;
  AFontName := FontName;
  ACharset  := FontCharset;
end;

procedure TfrmRVInsertSymbol.dgDrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
var sz: TSize;
    s: String;
    ws: WideString;
begin
  dg.Canvas.FillRect(Rect);
  dg.Canvas.Font.Name := FontName;
  dg.Canvas.Font.Charset := FontCharset;
  if FontCharset<>DEFAULT_CHARSET then begin
    s := Chr(32+ARow*dg.ColCount+ACol);
    sz := dg.Canvas.TextExtent(s);
    sz.cx := (Rect.Right-Rect.Left-sz.cx) div 2 + Rect.Left;
    sz.cy := (Rect.Bottom-Rect.Top-sz.cy) div 2 + Rect.Top;
    dg.Canvas.TextOut(sz.cx, sz.cy, s);
    end
  else begin
    if 32+ARow*dg.ColCount+ACol>$FFFF then
      exit;
    ws := WideChar(32+ARow*dg.ColCount+ACol);
    GetTextExtentPoint32W(dg.Canvas.Handle, PWideChar(ws), 1, sz);
    sz.cx := (Rect.Right-Rect.Left-sz.cx) div 2 + Rect.Left;
    sz.cy := (Rect.Bottom-Rect.Top-sz.cy) div 2 + Rect.Top;
    TextOutW(dg.Canvas.Handle, sz.cx, sz.cy, PWideChar(ws), 1);
  end;
end;

procedure TfrmRVInsertSymbol.dgSelectCell(Sender: TObject; ACol,
  ARow: Integer; var CanSelect: Boolean);
begin
  btnOk.Enabled := True;
  if FontCharset<>DEFAULT_CHARSET then
    Label1.Caption := Format('字符代码: %d', [32+ARow*dg.ColCount+ACol])
  else if 32+ARow*dg.ColCount+ACol>$FFFF then begin
    Label1.Caption := '(没有字符)';
    btnOk.Enabled := False;
    end
  else
    Label1.Caption := Format('字符代码: Unicode %d', [32+ARow*dg.ColCount+ACol]);
  if Panel=nil then
    exit;
  if FontCharset<>DEFAULT_CHARSET then
    Panel.Text := Chr(32+ARow*dg.ColCount+ACol)
  else begin
    if 32+ARow*dg.ColCount+ACol>$FFFF then
      Panel.TextW := ''
    else
      Panel.TextW := WideChar(32+ARow*dg.ColCount+ACol);
  end;
  Panel.SetBounds(
    dg.Left+(ACol-dg.LeftCol)*(dg.DefaultColWidth+1)-dg.DefaultColWidth div 2,
    dg.Top+(ARow-dg.TopRow)*(dg.DefaultRowHeight+1)-dg.DefaultRowHeight div 2,
    Panel.Width,Panel.Height
  );
  Panel.Invalidate;
end;

procedure TfrmRVInsertSymbol.dgTopLeftChanged(Sender: TObject);
var cs: Boolean;
begin
  dgSelectCell(Sender, dg.Col, dg.Row, cs);
end;

{ TZoomPanel }

procedure TZoomPanel.CMDenySubclassing(var Msg: TMessage);
begin
  Msg.Result := 1;
end;

procedure TZoomPanel.Paint;
var r: TRect;
    sz: TSize;
    w: Integer;
begin
  Canvas.Brush.Color := clHighlight;
  r := ClientRect;
  Canvas.FillRect(r);
  Canvas.Font.Height := Height-10;
  Canvas.Font.Name := FontName;
  Canvas.Font.Charset := FontCharset;
  Canvas.Font.Color := clHighlightText;
  Canvas.Pen.Color := clActiveBorder;
  Canvas.Rectangle(0,0,r.Right,r.Bottom);
  Canvas.Brush.Style := bsClear;
  if FontCharset<>DEFAULT_CHARSET then begin
    sz := Canvas.TextExtent(Text);
    w := sz.cx;
    sz.cx := (ClientWidth-sz.cx) div 2;
    sz.cy := (ClientHeight-sz.cy) div 2;
    Canvas.TextOut(sz.cx, sz.cy, Text);
    end
  else begin
    GetTextExtentPoint32W(Canvas.Handle, PWideChar(TextW), Length(TextW), sz);
    w := sz.cx;
    sz.cx := (ClientWidth-sz.cx) div 2;
    sz.cy := (ClientHeight-sz.cy) div 2;
    TextOutW(Canvas.Handle, sz.cx, sz.cy, PWideChar(TextW), Length(TextW));
  end;
  if w>DefWidth then
    Width := w
  else
    Width := DefWidth;
end;

procedure TZoomPanel.WMNCHitTest(var Message: TWMNCHitTest);
begin
  Message.Result := HTTRANSPARENT;
end;


procedure TfrmRVInsertSymbol.Build;
var
  DC: HDC;
  lf: TLogFont;
  CurrentCharset,idx: Integer;
  OC: TNotifyEvent;
  FontName:string;
begin
  FontName:=cmbFont1.Text;
  DC := GetDC(0);
  try
    if cmbCharset1.ItemIndex=-1 then
      CurrentCharset := -1
    else
      CurrentCharset := Integer(Charsets[cmbCharset1.ItemIndex]);
    cmbCharset1.Strings.Clear;
    if FontName<>'' then begin
      FillChar(lf, sizeof(lf), 0);
      lf.lfCharset  := DEFAULT_CHARSET;
      Move(PChar(FontName)^, lf.lfFaceName, Length(FontName));
      EnumFontFamiliesEx(DC, lf, @EnumFontCharsets, Longint(cmbCharset1),0);
      //if AddDefaultCharset then
      //cmbCharset1.Items.AddObject('(Default)', TObject(DEFAULT_CHARSET));
      idx := cmbCharset1.Strings.IndexOfObject(TObject(CurrentCharset));
      OC := cmbCharset1.OnItemClick;
      cmbCharset1.OnChange := nil;
      if (idx<>-1) then
        cmbCharset1.ItemIndex := idx
      else
        if cmbCharset1.Strings.Count>0 then
          cmbCharset1.ItemIndex := 0;
      cmbCharset1.OnItemClick := OC;
      if Assigned(cmbCharset1.OnItemClick) then
        cmbCharset1.OnItemClick(Self);
    end;
  finally
    ReleaseDC(0, DC);
  end;
end;

function TfrmRVInsertSymbol.GetCharsets(Index: Integer): TFontCharset;
begin
  Result := TFontCharset(cmbCharset1.Strings.Objects[Index]);
end;

procedure TfrmRVInsertSymbol.cmbCharset1AcceptText(Sender: TObject;
  var NewText: String; var Accept: Boolean);
begin
  Accept:=TTBXComboBoxItem(sender).Strings.IndexOf(NewText)<>-1;
  if Accept then
  begin
    cmbCharset1.Text:=NewText;
    cmbCharset1ItemClick(nil);
  end;
end;

procedure TfrmRVInsertSymbol.cmbFont1AcceptText(Sender: TObject;
  var NewText: String; var Accept: Boolean);
begin
  Accept:=TTBXComboBoxItem(sender).Strings.IndexOf(NewText)<>-1;
  if Accept then
  begin
    cmbFont1.Text:=NewText;
    cmbFont1ItemClick(sender);
  end;
end;

procedure TfrmRVInsertSymbol.cmbFont1ItemClick(Sender: TObject);
begin
  cmbFont1.ItemIndex:=cmbFont1.Strings.IndexOf(cmbFont1.Text);
  if cmbFont1.ItemIndex<0 then
    exit;
  dg.Invalidate;
  FontName := cmbFont1.Strings[cmbFont1.ItemIndex];
  if Panel<>nil then begin
    Panel.FontName := FontName;
    Panel.Invalidate;
  end;
  cmbCharset1.Text:=FontName;
  build;
end;

procedure TfrmRVInsertSymbol.cmbCharset1ItemClick(Sender: TObject);
begin
  cmbCharset1.ItemIndex:=cmbCharset1.Strings.IndexOf(cmbCharset1.Text);
  if cmbCharset1.ItemIndex<0 then
    exit;
  FontCharset := Charsets[cmbCharset1.ItemIndex];
  if Panel<>nil then
    Panel.FontCharset := FontCharset;
  if FontCharset=DEFAULT_CHARSET then
    dg.RowCount := 2340
  else
    dg.RowCount := 8;
  dg.Invalidate;
  dgTopLeftChanged(Sender);
end;

end.