小工具：把字体作为小图标一样排列显示出来供选择（对想作地图标注的朋友很有用）(0分)

  • 主题发起人 主题发起人 吕雪松
  • 开始时间 开始时间
吕

吕雪松

Unregistered / Unconfirmed
GUEST, unregistred user!

//// .pas
///////////////////////////////////////////////////////
unit frmSymbolSelect;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, ExtCtrls,Registry,GeoUtils;

type
TSymbolForm = class(TForm)
Panel1: TPanel;
Button1: TButton;
Button2: TButton;
ComboBox1: TComboBox;
Label1: TLabel;
Panel2: TPanel;
PaintBox1: TPaintBox;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
private
{ Private declarations }
CellSize : TPoint;
public
lfont : TLogfont;
NewFont,Oldfont : THandle;
do
wned : Boolean;
Symbol_ : string;
XX,YY : integer;
Buf : TBitMap;
{ Public declarations }
procedure GetCurrentFonts;
procedure UpdateSymbol;
procedure DrawGrid;
procedure ClearBuf;

end;


var
SymbolForm: TSymbolForm;

implementation

{$R *.DFM}

uses
SysReg;

procedure TSymbolForm.Button1Click(Sender: TObject);
begin

// Symbol_ := StringGrid1.Cells[XX,YY];
end;


procedure TSymbolForm.FormCreate(Sender: TObject);
begin

CellSize := Point(30,30);
GetCurrentFonts;

Buf := TBitmap.Create;
Buf.Width := PaintBox1.Width;
Buf.Height := PaintBox1.Height;

Width := 16 * CellSize.X + 10;
Height := 14* CellSize.Y + Panel1.Height + 30;

ClearBuf;
DrawGrid;
UpdateSymbol;

PaintBox1.refresh;
end;


procedure TSymbolForm.UpdateSymbol;
var
I,J,K : integer;
begin

Buf.Canvas.Font.Name := ComboBox1.Text;
Buf.Canvas.Font.Height := 30;
Buf.Canvas.Font.Color := clBlack;

Buf.Canvas.Brush.Style := bsClear;
I := 32;
for J := 0 to 13do

for K := 0 to 15do
begin

Buf.Canvas.TextOut(K * CellSize.X,J * CellSize.Y,Chr(I));
Inc(I);
end;

end;


procedure TSymbolForm.Button2Click(Sender: TObject);
begin

Close;
end;


procedure TSymbolForm.GetCurrentFonts;
var
Reg : TRegistry;
Key : string;
I,FontCount : integer;
KeyInfo : TRegKeyInfo;
FontList : TStringList;
begin

FontList := TStringList.Create;
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
//get version of windows, read different Registry value according of Win 9x/NT
case SysInfo.OSVer.dwPlatformId of
VER_PLATFORM_WIN32S : Key := '';
VER_PLATFORM_WIN32_WINDOWS : Key := '/SOFTWARE/Microsoft/Windows/CurrentVersion/Fonts/';
VER_PLATFORM_WIN32_NT : Key := '/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Fonts/';
end;

if Reg.OpenKey(Key,FALSE) then
begin

Reg.GetKeyInfo(KeyInfo);
Reg.GetValueNames(FontList);
FontList.Sort;
for I := 0 to FontList.Count - 1do
begin

ComboBox1.Items.Add(Trim(GetStrItem(FontList,'(',1)));
end;

ComboBox1.ItemIndex := 0;
end
else
begin

ShowMessage('读取注册表字体信息出错！');
end;


FontList.Free;
Reg.Free;
end;


procedure TSymbolForm.ComboBox1Change(Sender: TObject);
begin

ClearBuf;
DrawGrid;
UpdateSymbol;
PaintBox1.Refresh;
end;


procedure TSymbolForm.DrawGrid;
var
I,J : integer;
begin

Buf.Canvas.Pen.Color := clGray;
Buf.Canvas.Brush.Color := clWhite;
for I := 1 to 16do
begin

Buf.Canvas.MoveTo(I * CellSize.X,0);
Buf.Canvas.LineTo(I * CellSize.X,14 * CellSize.Y);
end;

for I := 1 to 14do
begin

Buf.Canvas.MoveTo(0,I * CellSize.Y);
Buf.Canvas.LineTo(16 * CellSize.X,I * CellSize.Y);
end;

end;


procedure TSymbolForm.FormDestroy(Sender: TObject);
begin

Buf.Free;
end;


procedure TSymbolForm.ClearBuf;
begin

Buf.Canvas.Brush.style := bsSolid;
Buf.Canvas.Pen.Color := clwhite;
Buf.Canvas.Brush.Color := clwhite;
Buf.Canvas.Rectangle(0,0,PaintBox1.Width,PaintBox1.Height);
end;


procedure TSymbolForm.PaintBox1Paint(Sender: TObject);
begin

PaintBox1.Canvas.Draw(0,0,Buf);
end;


procedure TSymbolForm.PaintBox1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: Integer);
var
RR : TRect;
begin


end;


end.
 
你太专业了
 
procedure TSymbolForm.PaintBox1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: Integer);
var
RR : TRect;
begin


end;

程序怎么没写完？还是这个过程没有用？(还没看全部代码就先问了)
 
研究研究～
 
to wind2000

你问的是，这部分代码已经补齐了，马上会帖在后面。
 
关注！！！
 
unit frmSymbolSelect;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, ExtCtrls,Registry,AppInfo,GeoUtils, Spin;

type
TSymbolForm = class(TForm)
Panel1: TPanel;
Button1: TButton;
ComboBox1: TComboBox;
Label1: TLabel;
Panel2: TPanel;
PaintBox1: TPaintBox;
Label3: TLabel;
Image1: TImage;
Bevel1: TBevel;
SpinEdit1: TSpinEdit;
Label2: TLabel;
Label4: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox1MouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
procedure PaintBox1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
private
{ Private declarations }
CellSize : TPoint;
nStartAsc : integer; //作为符号显示的起始AsciiCode数
public
lfont : TLogfont;
NewFont,Oldfont : THandle;
do
wned : Boolean;
Symbol_ : string;
FaceName_ : string;
FontSize_ : integer;
CurPos : TPoint;
Buf : TBitMap;
{ Public declarations }
procedure GetCurrentFonts;
procedure UpdateSymbol;
procedure DrawGrid;
procedure ClearBuf;
function GetCurSelSymbol : string;
procedure UpdateSample;
end;


var
SymbolForm: TSymbolForm;

implementation

{$R *.DFM}


procedure TSymbolForm.Button1Click(Sender: TObject);
begin

Close;
end;


procedure TSymbolForm.FormCreate(Sender: TObject);
begin

nStartAsc := 32;
CurPos := Point(0,0);
CellSize := Point(30,30);
GetCurrentFonts;

Buf := TBitmap.Create;
Buf.Width := PaintBox1.Width;
Buf.Height := PaintBox1.Height;

Width := 16 * CellSize.X + 10;
Height := 14* CellSize.Y + Panel1.Height + 30;

ClearBuf;
DrawGrid;
UpdateSymbol;

PaintBox1.refresh;
end;


procedure TSymbolForm.UpdateSymbol;
var
I,J,K : integer;
begin

Buf.Canvas.Font.Name := ComboBox1.Text;
Buf.Canvas.Font.Height := 30;
Buf.Canvas.Font.Color := clBlack;
Buf.Canvas.Brush.Style := bsClear;
I := nStartAsc;
for J := 0 to 13do

for K := 0 to 15do
begin

Buf.Canvas.TextOut(K * CellSize.X,J * CellSize.Y,Chr(I));
Inc(I);
end;

end;


procedure TSymbolForm.GetCurrentFonts;
var
Reg : TRegistry;
Key : string;
I,FontCount : integer;
KeyInfo : TRegKeyInfo;
FontList : TStringList;
begin

FontList := TStringList.Create;
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
//get version of windows, read different Registry value according of Win 9x/NT
case SysInfo.OSVer.dwPlatformId of
VER_PLATFORM_WIN32S : Key := '';
VER_PLATFORM_WIN32_WINDOWS : Key := '/SOFTWARE/Microsoft/Windows/CurrentVersion/Fonts/';
VER_PLATFORM_WIN32_NT : Key := '/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Fonts/';
end;


if Reg.OpenKey(Key,FALSE) then
begin

Reg.GetKeyInfo(KeyInfo);
Reg.GetValueNames(FontList);
FontList.Sort;
for I := 0 to FontList.Count - 1do
begin

ComboBox1.Items.Add(Trim(GetStrItem(FontList,'(',1)));
end;

ComboBox1.ItemIndex := 0;
end
else
begin

ShowMessage('读取注册表字体信息出错！');
end;


FontList.Free;
Reg.Free;
end;


procedure TSymbolForm.ComboBox1Change(Sender: TObject);
begin

ClearBuf;
DrawGrid;
UpdateSymbol;
PaintBox1.Refresh;
UpdateSample;
end;


procedure TSymbolForm.DrawGrid;
var
I,J : integer;
begin

Buf.Canvas.Pen.Color := clGray;
Buf.Canvas.Brush.Color := clWhite;
for I := 1 to 16do
begin

Buf.Canvas.MoveTo(I * CellSize.X,0);
Buf.Canvas.LineTo(I * CellSize.X,14 * CellSize.Y);
end;

for I := 1 to 14do
begin

Buf.Canvas.MoveTo(0,I * CellSize.Y);
Buf.Canvas.LineTo(16 * CellSize.X,I * CellSize.Y);
end;

end;


procedure TSymbolForm.FormDestroy(Sender: TObject);
begin

Buf.Free;
end;


procedure TSymbolForm.ClearBuf;
begin

Buf.Canvas.Brush.style := bsSolid;
Buf.Canvas.Pen.Color := clwhite;
Buf.Canvas.Brush.Color := clwhite;
Buf.Canvas.Rectangle(0,0,PaintBox1.Width,PaintBox1.Height);
end;


procedure TSymbolForm.PaintBox1Paint(Sender: TObject);
begin

PaintBox1.Canvas.Draw(0,0,Buf);
PaintBox1.Canvas.DrawFocusRect(Rect(CurPos.X * CellSize.X + 1,CurPos.Y * CellSize.Y + 1,(CurPos.X + 1) * CellSize.X,(CurPos.Y + 1) * CellSize.Y));
end;


procedure TSymbolForm.PaintBox1MouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: Integer);
var
TmpPos : TPoint;
begin

TmpPos := Point(Trunc(X/CellSize.X),Trunc(Y/CellSize.Y));
if (TmpPos.X <> CurPos.X) or (TmpPos.Y <> CurPos.Y) then
begin

CurPos := TmpPos;
PaintBox1.Canvas.Draw(0,0,Buf);
PaintBox1.Canvas.DrawFocusRect(Rect(CurPos.X * CellSize.X + 1,CurPos.Y * CellSize.Y + 1,(CurPos.X + 1) * CellSize.X,(CurPos.Y + 1) * CellSize.Y));
end;

end;


procedure TSymbolForm.PaintBox1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
begin

UpdateSample;
end;


function TSymbolForm.GetCurSelSymbol: string;
begin

Symbol_ := Chr(nStartAsc + CurPos.X + 16 * CurPos.Y);
FaceName_ := ComboBox1.Text;
FontSize_ := SpinEdit1.Value;
result := Symbol_;
end;


procedure TSymbolForm.UpdateSample;
begin

with Image1.Canvasdo
begin

Brush.Color := clWhite;
FillRect(Rect(0,0,Image1.Width,Image1.Height));
Pen.Color := clBlack;
Font.Name := ComboBox1.Text;
Font.Size := SpinEdit1.Value;
TextOut(0,0,GetCurSelSymbol);
end;

end;


end.
 
很有帮助哦！~
 
您必须登录或注册才可回复。

Similar threads

W
高手帮忙啊 FASTREPORT 的数组作为数据源问题,请看,我现在在公司加班,可怜.....(40分)
回复
2
查看
287
wyismail
W
L
连续发送截屏图象后的问题！！(100分)
2
回复
26
查看
340
wql
W
L
文章的最后有###春节晚会节目单####-用xmldocument组件合并两个xml文件，合并的结点不能正确的输出到文件，why？ (200分)
回复
12
查看
323
ljf945
L
T
一个关于Listview 显示缩略图的问题 见鬼了 (50分)
回复
4
查看
195
travis
T
P
为什么我写的读取网卡MAC的程序在win2000下有时会出错（有源码）？(100分)
回复
3
查看
314
paf
P
后退
顶部