关于字体显示的问题，请各位大侠共同分析分析！！ ( 积分: 100 )

L

Lu_JR

Unregistered / Unconfirmed
GUEST, unregistred user!
最近盒子下载了一个仿速达界面控件，其中的页面控制及下拉框在Win98无法正常显示字体，在Win2000及WinXP均可正常显示字体代码附后，请各位大侠共同分析分析！

////////////// UnitASPages //////////////

{*******************************************************
仿速达的功能界面

By wr960204 王锐

2004/8/8
*******************************************************}
unit UnitASPages;

{$S-,W-,R-,H+,X+}
{$C PRELOAD}

interface

uses
Messages, Windows, SysUtils, Classes, UnitASBase, UnitASUtils,
Controls, Forms, Menus, Graphics, StdCtrls;

type
TDrawNavigation = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Active: Boolean) of object;

type
//页
TASPage = class(TASBase)
private

procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
protected
procedure ReadState(Reader: TReader); override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Caption;
property Height stored False;
property TabOrder stored False;
property Visible stored False;
property Width stored False;

end;
//仿速达的功能界面
TASPageControl = class(TASBase)
private
FPageList: TList;
FAccess: TStrings;
FPageIndex: Integer;

FNavigation3D: Boolean;
FNavigationWidth: Integer;
FNavigationFont: TFont;
FNavigationAcitveFont: TFont;
FNavigationColor: TColor;

FBufferBMP: TBitmap;
FOnPageChanged: TNotifyEvent;
FOnDrawNavigation: TDrawNavigation;
procedure SeTASPages(Value: TStrings);
procedure SetActivePage(const Value: string);
function GetActivePage: string;
procedure SeTASPageIndex(Value: Integer);
procedure SetNavigationAcitveFont(const Value: TFont);
procedure SetNavigationColor(const Value: TColor);
procedure SetNavigationFont(const Value: TFont);
function GeTASPageIndexFormPos(X, Y: Integer): Integer;
procedure SetNavigationWidth(const Value: Integer);
procedure SetNavigation3D(const Value: Boolean);
protected

procedure CreateParams(var Params: TCreateParams); override;
function GetChildOwner: TComponent; override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure ReadState(Reader: TReader); override;
procedure ShowControl(AControl: TControl); override;
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X: Integer; Y: Integer); override;

procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMLButtonDown(var Message: TWMLButtonDown);
message WM_LBUTTONDOWN;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GeTASPageRect: TRect;
published
property Navigation3D: Boolean read FNavigation3D write SetNavigation3D;
//导航的字体
property NavigationFont: TFont read FNavigationFont write SetNavigationFont;
//导航处于活动时的字体
property NavigationAcitveFont: TFont read FNavigationAcitveFont write
SetNavigationAcitveFont;
//导航的颜色
property NavigationColor: TColor read FNavigationColor write
SetNavigationColor;
//导航的宽度
property NavigationWidth: Integer read FNavigationWidth write
SetNavigationWidth;
//设置当前页面
property ActivePage: string read GetActivePage write SetActivePage stored
False;
property Align;
property Anchors;
property Color;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Font;
property Enabled;
property Constraints;
//页面索引
property PageIndex: Integer read FPageIndex write SeTASPageIndex default
0;
//页面
property Pages: TStrings read FAccess write SeTASPages stored False;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
//切换页面
property OnPageChanged: TNotifyEvent read FOnPageChanged write
FOnPageChanged;
property OnDrawNavigation: TDrawNavigation read FOnDrawNavigation
write FOnDrawNavigation;
property OnStartDock;
property OnStartDrag;
end;
implementation

uses
Consts;
//画出3D的边框

procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor:
TColor;
Width: Integer);

procedure DoRect;
var
TopRight, BottomLeft: TPoint;
begin
with Canvas, Rect do
begin
TopRight.X := Right;
TopRight.Y := Top;
BottomLeft.X := Left;
BottomLeft.Y := Bottom;
Pen.Color := TopColor;
PolyLine([BottomLeft, TopLeft, TopRight]);
Pen.Color := BottomColor;
Dec(BottomLeft.X);
PolyLine([TopRight, BottomRight, BottomLeft]);
end;
end;

begin
Canvas.Pen.Width := 1;
Dec(Rect.Bottom);
Dec(Rect.Right);
while Width > 0 do
begin
Dec(Width);
DoRect;
InflateRect(Rect, -1, -1);
end;
Inc(Rect.Bottom);
Inc(Rect.Right);
end;

//画出导航的切换按钮

function DrawNavigationButtonFace(Canvas: TCanvas; const Client: TRect;
BevelWidth: Integer): TRect;
const
IsRounded = True;
var
R : TRect;
C1, C2 : TColor;
begin

R := Client;
with Canvas do
begin
Pen.Color := clWindowFrame;
Brush.Style := bsSolid;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);

if IsRounded then
begin
Pixels[R.Left, R.Top] := clBtnFace;
Pixels[R.Left, R.Bottom - 1] := clBtnFace;
Pixels[R.Right - 1, R.Top] := clBtnFace;
Pixels[R.Right - 1, R.Bottom - 1] := clBtnFace;
end;

InflateRect(R, -1, -1);
C1 := RGB(GetRValue(Brush.Color) - 5, GetRValue(Brush.Color) - 5,
GetRValue(Brush.Color) - 5);
C2 := RGB(GetRValue(Brush.Color) + 10, GetRValue(Brush.Color) + 10,
GetRValue(Brush.Color) + 10);
Frame3D(Canvas, R, C1, C2, BevelWidth);

end;

Result := Rect(Client.Left + 1, Client.Top + 1,
Client.Right - 2, Client.Bottom - 2);
OffsetRect(Result, 1, 1);
end;

{ TASPageAccess }

type
TASPageAccess = class(TStrings)
private
PageList: TList;
Notebook: TASPageControl;
protected
function GetCount: Integer; override;
function Get(Index: Integer): string; override;
function GetObject(Index: Integer): TObject; override;
procedure SetUpdateState(Updating: Boolean); override;
procedure Put(Index: Integer; const S: string); override;
public
constructor Create(APageList: TList; ANotebook: TASPageControl);
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
procedure Move(CurIndex, NewIndex: Integer); override;
end;

constructor TASPageAccess.Create(APageList: TList; ANotebook:
TASPageControl);
begin
inherited Create;
PageList := APageList;
Notebook := ANotebook;
end;

function TASPageAccess.GetCount: Integer;
begin
Result := PageList.Count;
end;

function TASPageAccess.Get(Index: Integer): string;
begin
Result := TASPage(PageList[Index]).Caption;
end;

procedure TASPageAccess.Put(Index: Integer; const S: string);
begin
TASPage(PageList[Index]).Caption := S;
Notebook.Invalidate;
end;

function TASPageAccess.GetObject(Index: Integer): TObject;
begin
Result := PageList[Index];
end;

procedure TASPageAccess.SetUpdateState(Updating: Boolean);
begin
{ do nothing }
end;

procedure TASPageAccess.Clear;
var
I : Integer;
begin
for I := 0 to PageList.Count - 1 do
TASPage(PageList).Free;
PageList.Clear;
end;

procedure TASPageAccess.Delete(Index: Integer);
var
Form : TCustomForm;
begin
TASPage(PageList[Index]).Free;
PageList.Delete(Index);
NoteBook.PageIndex := 0;

if csDesigning in NoteBook.ComponentState then
begin
Form := GetParentForm(NoteBook);
if (Form <> nil) and (Form.Designer <> nil) then
Form.Designer.Modified;
end;
end;

procedure TASPageAccess.Insert(Index: Integer; const S: string);
var
Page : TASPage;
Form : TCustomForm;
begin
Page := TASPage.Create(Notebook);
with Page do
begin
Parent := Notebook;
Caption := S;
end;
PageList.Insert(Index, Page);

NoteBook.PageIndex := Index;

if csDesigning in NoteBook.ComponentState then
begin
Form := GetParentForm(NoteBook);
if (Form <> nil) and (Form.Designer <> nil) then
Form.Designer.Modified;
end;
end;

procedure TASPageAccess.Move(CurIndex, NewIndex: Integer);
var
AObject : TObject;
begin
if CurIndex <> NewIndex then
begin
AObject := PageList[CurIndex];
PageList[CurIndex] := PageList[NewIndex];
PageList[NewIndex] := AObject;
NoteBook.PageIndex := NewIndex;
end;
end;

{ TASPage }

constructor TASPage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Visible := False;
ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible,
csParentBackground];
end;

procedure TASPage.Paint;
begin
inherited Paint;
Canvas.Brush.Color := TASPageControl(Owner).Color;
Canvas.FillRect(ClientRect);
end;

procedure TASPage.ReadState(Reader: TReader);
begin
if Reader.Parent is TASPageControl then
TASPageControl(Reader.Parent).FPageList.Add(Self);
inherited ReadState(Reader);
end;

procedure TASPage.WMNCHitTest(var Message: TWMNCHitTest);
begin
if not (csDesigning in ComponentState) then
Message.Result := HTTRANSPARENT
else
inherited;
end;

{ TASPageControl }

var
Registered : Boolean = False;

constructor TASPageControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 150;
Height := 150;
FNavigationWidth := 100;
FPageList := TList.Create;
FAccess := TASPageAccess.Create(FPageList, Self);
FPageIndex := -1;
//
FAccess.Add('默认页面');
PageIndex := 0;
//
Exclude(FComponentStyle, csInheritable);
//
FNavigation3D := True;

//
Self.Color := $00BEE9EB;
FNavigationColor := $00408000;

DoubleBuffered := True;
FBufferBMP := TBitmap.Create;
////////////
FNavigationFont := TFont.Create;
FNavigationFont.Color := clWhite;
FNavigationFont.Style := [fsBold];
FNavigationAcitveFont := TFont.Create;
FNavigationAcitveFont.Color := clBlack;
FNavigationAcitveFont.Style := [fsBold];
//////////////
ControlStyle := ControlStyle + [csParentBackground];

if not Registered then
begin
Classes.RegisterClasses([TASPage]);
Registered := True;
end;
end;

destructor TASPageControl.Destroy;
begin
FBufferBMP.Free;
FAccess.Free;
FPageList.Free;
inherited Destroy;
end;

procedure TASPageControl.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style or WS_CLIPCHILDREN;
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;

function TASPageControl.GetChildOwner: TComponent;
begin
Result := Self;
end;

procedure TASPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
I : Integer;
begin
for I := 0 to FPageList.Count - 1 do
Proc(TControl(FPageList));
end;

procedure TASPageControl.ReadState(Reader: TReader);
begin
Pages.Clear;
inherited ReadState(Reader);
if (FPageIndex <> -1) and (FPageIndex >= 0) and (FPageIndex < FPageList.Count)
then
with TASPage(FPageList[FPageIndex]) do
begin
BringToFront;
Visible := True;
Left := FNavigationWidth;
Width := Self.Width - FNavigationWidth;
Top := 0;
Height := Self.Height;
end
else
FPageIndex := -1;
end;

procedure TASPageControl.ShowControl(AControl: TControl);
var
I : Integer;
begin
for I := 0 to FPageList.Count - 1 do
if FPageList = AControl then
begin
SeTASPageIndex(I);
Exit;
end;
inherited ShowControl(AControl);
end;

procedure TASPageControl.SeTASPages(Value: TStrings);
begin
FAccess.Assign(Value);
end;

procedure TASPageControl.SeTASPageIndex(Value: Integer);
var
ParentForm : TCustomForm;
begin
if csLoading in ComponentState then
begin
FPageIndex := Value;
Exit;
end;
if (Value <> FPageIndex) and (Value >= 0) and (Value < FPageList.Count) then
begin
ParentForm := GetParentForm(Self);
if ParentForm <> nil then
if ContainsControl(ParentForm.ActiveControl) then
ParentForm.ActiveControl := Self;
with TASPage(FPageList[Value]) do
begin
BringToFront;
Visible := True;
Left := FNavigationWidth;
Width := Self.Width - FNavigationWidth;
Top := 0;
Height := Self.Height;
end;
if (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then
TASPage(FPageList[FPageIndex]).Visible := False;
FPageIndex := Value;
if ParentForm <> nil then
if ParentForm.ActiveControl = Self then
SelectFirst;
if Assigned(FOnPageChanged) then
FOnPageChanged(Self);
end;
Invalidate;
end;

procedure TASPageControl.SetActivePage(const Value: string);
begin
SeTASPageIndex(FAccess.IndexOf(Value));
end;

function TASPageControl.GetActivePage: string;
begin
Result := FAccess[FPageIndex];
end;

procedure TASPageControl.SetNavigationAcitveFont(const Value: TFont);
begin
FNavigationAcitveFont.Assign(Value);
Invalidate;
end;

procedure TASPageControl.SetNavigationColor(const Value: TColor);
begin
FNavigationColor := Value;
Invalidate;
end;

procedure TASPageControl.SetNavigationFont(const Value: TFont);
begin
FNavigationFont.Assign(Value);
Invalidate;
end;

procedure TASPageControl.Paint;
var
ACanvas : TCanvas;
ARect : TRect;
NavigationHeight : Integer;
I : Integer;

procedure DrawNavigationText(AText: string; Font: TFont; ARect: TRect);
var
oldFont : TFont;
begin
OldFont := TFont.Create;
try
OldFont.Assign(ACanvas.Font);
ACanvas.Font := Font;
DrawText(ACanvas, AText, ARect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
ACanvas.Font := oldFont;
finally
OldFont.Free;
end;
end;

var

L, R : Integer;
NRect, BRect : TRect;
begin
inherited Paint();

FBufferBMP.Width := 0;
FBufferBMP.Height := 0;
FBufferBMP.Width := FNavigationWidth;
FBufferBMP.Height := Self.Height;
//
ACanvas := FBufferBMP.Canvas;

ACanvas.Lock;
try
ARect := Rect(0, 0, FNavigationWidth, Self.Height);
ACanvas.Brush.Color := Color;
ACanvas.FillRect(ARect);
if FAccess.Count = 0 then
Exit;
NavigationHeight := Self.Height div FAccess.Count;
ACanvas.Brush.Color := FNavigationColor;
for I := 0 to FAccess.Count - 1 do
begin
ARect := Rect(0, I * NavigationHeight, FNavigationWidth,
(I + 1) * NavigationHeight + 1);
if I = FPageIndex then
begin
ACanvas.Brush.Color := Color;
ACanvas.FillRect(ARect);
ACanvas.Brush.Color := FNavigationColor;
DrawNavigationText(FAccess, FNavigationAcitveFont, ARect);

end
else
begin
if FNavigation3D then
begin
DrawNavigationButtonFace(ACanvas, ARect, 1);
end
else
begin
ACanvas.FillRect(ARect);
ACanvas.Rectangle(ARect);
end;
DrawNavigationText(FAccess, FNavigationFont, ARect);
end;
if Assigned(FOnDrawNavigation) then
FOnDrawNavigation(Self, ACanvas, ARect, I = FPageIndex);
end;

NRect := Rect(0, 0, FNavigationWidth, Self.ClientHeight);
BRect := Rect(0, 0, FBufferBMP.Width, FBufferBMP.Height);
Self.Canvas.CopyRect(NRect, ACanvas, BRect);
finally
ACanvas.Unlock;
end;
end;

procedure TASPageControl.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
PageIndex := GeTASPageIndexFormPos(X, Y);
Invalidate;
end;

function TASPageControl.GeTASPageIndexFormPos(X, Y: Integer): Integer;
var
I : Integer;
ARect : TRect;
NavigationHeight : Integer;
begin
Result := FPageIndex;
if FAccess.Count = 0 then
Exit;
NavigationHeight := Self.Height div FAccess.Count;
for I := 0 to FAccess.Count - 1 do
begin
ARect := Rect(0, I * NavigationHeight, FNavigationWidth - 1,
(I + 1) * NavigationHeight);
if (X > ARect.Left) and (X < ARect.Right) and
(Y > ARect.Top) and (Y < ARect.Bottom) then
begin
Result := I;
Exit;
end;
end;
end;

procedure TASPageControl.WMSize(var Message: TWMSize);
begin
inherited;
if csLoading in ComponentState then
Exit;
if FPageList.Count > 0 then
begin
TASPage(FPageList[FPageIndex]).Left := FNavigationWidth;
TASPage(FPageList[FPageIndex]).Width := Width - FNavigationWidth;
TASPage(FPageList[FPageIndex]).Height := Height;
TASPage(FPageList[FPageIndex]).Top := 0;
Invalidate;
end;
end;

function TASPageControl.GeTASPageRect: TRect;
begin
Result := REct(TASPage(FPageList[PageIndex]).Left,
TASPage(FPageList[PageIndex]).Top,
TASPage(FPageList[PageIndex]).Left +
TASPage(FPageList[PageIndex]).Width,
TASPage(FPageList[PageIndex]).Top +
TASPage(FPageList[PageIndex]).Height);
end;

procedure TASPageControl.SetNavigationWidth(const Value: Integer);
begin
if FNavigationWidth <> Value then
begin
FNavigationWidth := Value;
if csLoading in ComponentState then
Exit;
TASPage(FPageList[PageIndex]).Left := Value;
TASPage(FPageList[PageIndex]).Width := Width - Value;
TASPage(FPageList[PageIndex]).Top := 0;
TASPage(FPageList[PageIndex]).Height := Height;
Invalidate;
end;
end;

procedure TASPageControl.WMLButtonDown(var Message: TWMLButtonDown);
begin
if (csDesigning in ComponentState) then
begin
PageIndex := GeTASPageIndexFormPos(Message.XPos, Message.YPos);
Invalidate;
end
else
begin
inherited;
end;
end;

procedure TASPageControl.SetNavigation3D(const Value: Boolean);
begin
if FNavigation3D <> Value then
begin
FNavigation3D := Value;
Invalidate;
end;
end;

end.
/////////////////////////

///////////所调用到的　UnitASBase　//////////////////

{*******************************************************
By wr960204 王锐

2004/8/8
*******************************************************}
unit UnitASBase;

interface
uses
Controls;

Type
TASBase = Class(TCustomControl)
private
FAbout:String;
function GetCurrentVer: Double;
public
property CurrentVer:Double read GetCurrentVer;
published
property About:String read FAbout write FAbout;
end;

implementation

{ TASBase }
Const
CurrentVer = 0.5;


function TASBase.GetCurrentVer: Double;
begin
Result := CurrentVer;
end;

end.
///////////////////////////////////////////

//////////////所调用到的 UnitASUtils /////////////////////

unit UnitASUtils;

interface
uses
Windows, Controls, Graphics, Classes, SysUtils;

function TextWidth(Canvas: TCanvas; AText: WideString; Flags: Integer = 0):
integer;
overload;
function TextHeight(Canvas: TCanvas; AText: WideString): integer; overload;

procedure FillRect(Canvas: TCanvas; Rect: TRect; Color: TColor); overload;

procedure FillRect(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer;
Color: TColor); overload;

function DrawText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag:
cardinal): integer; overload;

function DrawText(ACanvas: TCanvas; AText: WideString; X, Y: integer): integer;
overload;

function CurrencyFrameCellWidth(ACanvas: TCanvas): Integer;

function ChineseCurrencyText(AText: WideString; ACurrencySymbol: WideChar):
Widestring;

procedure DrawCurrencyFrame(ACanvas: TCanvas; ARect: TRect; Value:
Currency; CurrencySymbol: WideChar; DrawZeroValue: Boolean = False);

function IsWinNT: Boolean;

implementation

function IsWinNT: Boolean;
var
VI: TOSVersionInfo;
begin
VI.dwOSVersionInfoSize := SizeOf(VI);
GetVersionEx(VI);
Result := VI.dwPlatformId = VER_PLATFORM_WIN32_NT;
end;

function TextWidth(Canvas: TCanvas; AText: WideString; Flags: Integer = 0):
integer;
begin
Result := Canvas.TextWidth(AText);
end;

function TextHeight(Canvas: TCanvas; AText: WideString): integer;
begin
Result := Canvas.TextHeight(AText);
end;

procedure FillRect(Canvas: TCanvas; Rect: TRect; Color: TColor);
begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
Canvas.FillRect(Rect);
end;

procedure FillRect(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer;
Color: TColor); overload;
begin
FillRect(Canvas, Rect(ALeft, ATop, ARight, ABottom), Color);
end;

function DrawText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag:
cardinal): integer;
begin
Result := Windows.DrawTextW(ACanvas.Handle, PWideChar(AText),
Length(AText), Bounds, Flag);
end;

function DrawText(ACanvas: TCanvas; AText: WideString; X, Y: integer): integer;
var
R: TRect;
begin
R := Rect(X, Y, X + TextWidth(ACanvas, AText), Y + TextHeight(ACanvas,
AText));
Result := DrawText(ACanvas, AText, R, 0);
end;

function CurrencyFrameCellWidth(ACanvas: TCanvas): Integer;
var
I: Integer;
Tmp: Integer;
begin
Result := 0;
for I := 30 to 39 do
begin
Tmp := ACanvas.TextWidth(Char(I)) + 2;
if Result < Tmp then
Result := Tmp;
end;
end;

function ChineseCurrencyText(AText: WideString; ACurrencySymbol: WideChar):
Widestring;
var
TmpStr: WideString;
P: PWideChar;
CurrValue: Currency;
begin
Result := '';
if not TryStrToCurr(AText, CurrValue) then
CurrValue := 0;
TmpStr := FormatFloat('0.00', Abs(CurrValue));
P := PWideChar(TmpStr);
while P^ <> WideChar(#0) do
begin
if P^ <> WideChar('.') then
Result := Result + P^;
Inc(P);
end;
Result := ACurrencySymbol + Result;
end;

procedure DrawCurrencyFrame(ACanvas: TCanvas; ARect: TRect; Value:
Currency; CurrencySymbol: WideChar; DrawZeroValue: Boolean = False);
const
//CurrencySymbol = '￥';
DecimalNumber = 2;
DigitalNumber = 10;
DecimalSeparatorColor = clRed;
KilobitSeparatorColor = clBlack;
GridLineColor = clMoneyGreen;
GridLineWidth = 1;
var
I: Integer;
RectWidth, RectHeight: Integer;
CX, CY: Integer;
LineNum: Integer;
IsNegative: Boolean; //是否是负数
AText: WideString;
CellWidth: Integer;
CharRect: TRect;
PCurrentChar: PWideChar;
OldFontColor: TColor;
DrawEnd: Boolean;
begin
OldFontColor := ACanvas.Font.Color;
//ShowMessage(IntToStr(ACanvas.Font.Size));
//CellWidth := ACanvas.TextWidth('0') + 2;
CellWidth := CurrencyFrameCellWidth(ACanvas);
IsNegative := (Value < 0);
AText := CurrencySymbol + FormatFloat('0.00', Value);
RectWidth := ARect.Right - ARect.Left;
RectHeight := ARect.Bottom - ARect.Top;
CX := ARect.Right - CellWidth;
CY := 0;
LineNum := -2;
PCurrentChar := @(AText[length(AText)]);
DrawEnd := False;
while CX > 0 do
begin
Inc(LineNum);
if (Value <> 0)or(DrawZeroValue) then
begin
CharRect := Rect(CX + GridLineWidth, CY, CX + CellWidth, CY + RectHeight);
if IsNegative then //负数是红色的；正数是黑色的
ACanvas.Font.Color := clRed
else
ACanvas.Font.Color := clBlack;

if not DrawEnd then
begin
DrawTextW(ACanvas.Handle, PCurrentChar, 1, CharRect, DT_SINGLELINE or
DT_CENTER or DT_VCENTER);
if PCurrentChar^ = CurrencySymbol then //划到了货币符号以后就不画字符了
DrawEnd := true;
end;
end;
if LineNum = 0 then
ACanvas.Pen.Color := DecimalSeparatorColor
else
if (LineNum mod 3) = 0 then
ACanvas.Pen.Color := KilobitSeparatorColor
else
ACanvas.Pen.Color := GridLineColor;
ACanvas.MoveTo(CX, CY);
ACanvas.LineTo(CX, CY + RectHeight);
Dec(CX, CellWidth);
Dec(PCurrentChar);
if (PCurrentChar^ = Widechar('.'))
or (PCurrentChar^ = Widechar('-')) then //跳过小数点、负号不画
Dec(PCurrentChar);
end;
ACanvas.Font.Color := OldFontColor;
end;

end.

///////////////////////////////////

备注：我写过信给作者，到现在还没回复。
 
L

Lu_JR

Unregistered / Unconfirmed
GUEST, unregistred user!
最近盒子下载了一个仿速达界面控件，其中的页面控制及下拉框在Win98无法正常显示字体，在Win2000及WinXP均可正常显示字体代码附后，请各位大侠共同分析分析！

////////////// UnitASPages //////////////

{*******************************************************
仿速达的功能界面

By wr960204 王锐

2004/8/8
*******************************************************}
unit UnitASPages;

{$S-,W-,R-,H+,X+}
{$C PRELOAD}

interface

uses
Messages, Windows, SysUtils, Classes, UnitASBase, UnitASUtils,
Controls, Forms, Menus, Graphics, StdCtrls;

type
TDrawNavigation = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Active: Boolean) of object;

type
//页
TASPage = class(TASBase)
private

procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
protected
procedure ReadState(Reader: TReader); override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Caption;
property Height stored False;
property TabOrder stored False;
property Visible stored False;
property Width stored False;

end;
//仿速达的功能界面
TASPageControl = class(TASBase)
private
FPageList: TList;
FAccess: TStrings;
FPageIndex: Integer;

FNavigation3D: Boolean;
FNavigationWidth: Integer;
FNavigationFont: TFont;
FNavigationAcitveFont: TFont;
FNavigationColor: TColor;

FBufferBMP: TBitmap;
FOnPageChanged: TNotifyEvent;
FOnDrawNavigation: TDrawNavigation;
procedure SeTASPages(Value: TStrings);
procedure SetActivePage(const Value: string);
function GetActivePage: string;
procedure SeTASPageIndex(Value: Integer);
procedure SetNavigationAcitveFont(const Value: TFont);
procedure SetNavigationColor(const Value: TColor);
procedure SetNavigationFont(const Value: TFont);
function GeTASPageIndexFormPos(X, Y: Integer): Integer;
procedure SetNavigationWidth(const Value: Integer);
procedure SetNavigation3D(const Value: Boolean);
protected

procedure CreateParams(var Params: TCreateParams); override;
function GetChildOwner: TComponent; override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure ReadState(Reader: TReader); override;
procedure ShowControl(AControl: TControl); override;
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X: Integer; Y: Integer); override;

procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMLButtonDown(var Message: TWMLButtonDown);
message WM_LBUTTONDOWN;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GeTASPageRect: TRect;
published
property Navigation3D: Boolean read FNavigation3D write SetNavigation3D;
//导航的字体
property NavigationFont: TFont read FNavigationFont write SetNavigationFont;
//导航处于活动时的字体
property NavigationAcitveFont: TFont read FNavigationAcitveFont write
SetNavigationAcitveFont;
//导航的颜色
property NavigationColor: TColor read FNavigationColor write
SetNavigationColor;
//导航的宽度
property NavigationWidth: Integer read FNavigationWidth write
SetNavigationWidth;
//设置当前页面
property ActivePage: string read GetActivePage write SetActivePage stored
False;
property Align;
property Anchors;
property Color;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Font;
property Enabled;
property Constraints;
//页面索引
property PageIndex: Integer read FPageIndex write SeTASPageIndex default
0;
//页面
property Pages: TStrings read FAccess write SeTASPages stored False;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
//切换页面
property OnPageChanged: TNotifyEvent read FOnPageChanged write
FOnPageChanged;
property OnDrawNavigation: TDrawNavigation read FOnDrawNavigation
write FOnDrawNavigation;
property OnStartDock;
property OnStartDrag;
end;
implementation

uses
Consts;
//画出3D的边框

procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor:
TColor;
Width: Integer);

procedure DoRect;
var
TopRight, BottomLeft: TPoint;
begin
with Canvas, Rect do
begin
TopRight.X := Right;
TopRight.Y := Top;
BottomLeft.X := Left;
BottomLeft.Y := Bottom;
Pen.Color := TopColor;
PolyLine([BottomLeft, TopLeft, TopRight]);
Pen.Color := BottomColor;
Dec(BottomLeft.X);
PolyLine([TopRight, BottomRight, BottomLeft]);
end;
end;

begin
Canvas.Pen.Width := 1;
Dec(Rect.Bottom);
Dec(Rect.Right);
while Width > 0 do
begin
Dec(Width);
DoRect;
InflateRect(Rect, -1, -1);
end;
Inc(Rect.Bottom);
Inc(Rect.Right);
end;

//画出导航的切换按钮

function DrawNavigationButtonFace(Canvas: TCanvas; const Client: TRect;
BevelWidth: Integer): TRect;
const
IsRounded = True;
var
R : TRect;
C1, C2 : TColor;
begin

R := Client;
with Canvas do
begin
Pen.Color := clWindowFrame;
Brush.Style := bsSolid;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);

if IsRounded then
begin
Pixels[R.Left, R.Top] := clBtnFace;
Pixels[R.Left, R.Bottom - 1] := clBtnFace;
Pixels[R.Right - 1, R.Top] := clBtnFace;
Pixels[R.Right - 1, R.Bottom - 1] := clBtnFace;
end;

InflateRect(R, -1, -1);
C1 := RGB(GetRValue(Brush.Color) - 5, GetRValue(Brush.Color) - 5,
GetRValue(Brush.Color) - 5);
C2 := RGB(GetRValue(Brush.Color) + 10, GetRValue(Brush.Color) + 10,
GetRValue(Brush.Color) + 10);
Frame3D(Canvas, R, C1, C2, BevelWidth);

end;

Result := Rect(Client.Left + 1, Client.Top + 1,
Client.Right - 2, Client.Bottom - 2);
OffsetRect(Result, 1, 1);
end;

{ TASPageAccess }

type
TASPageAccess = class(TStrings)
private
PageList: TList;
Notebook: TASPageControl;
protected
function GetCount: Integer; override;
function Get(Index: Integer): string; override;
function GetObject(Index: Integer): TObject; override;
procedure SetUpdateState(Updating: Boolean); override;
procedure Put(Index: Integer; const S: string); override;
public
constructor Create(APageList: TList; ANotebook: TASPageControl);
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
procedure Move(CurIndex, NewIndex: Integer); override;
end;

constructor TASPageAccess.Create(APageList: TList; ANotebook:
TASPageControl);
begin
inherited Create;
PageList := APageList;
Notebook := ANotebook;
end;

function TASPageAccess.GetCount: Integer;
begin
Result := PageList.Count;
end;

function TASPageAccess.Get(Index: Integer): string;
begin
Result := TASPage(PageList[Index]).Caption;
end;

procedure TASPageAccess.Put(Index: Integer; const S: string);
begin
TASPage(PageList[Index]).Caption := S;
Notebook.Invalidate;
end;

function TASPageAccess.GetObject(Index: Integer): TObject;
begin
Result := PageList[Index];
end;

procedure TASPageAccess.SetUpdateState(Updating: Boolean);
begin
{ do nothing }
end;

procedure TASPageAccess.Clear;
var
I : Integer;
begin
for I := 0 to PageList.Count - 1 do
TASPage(PageList).Free;
PageList.Clear;
end;

procedure TASPageAccess.Delete(Index: Integer);
var
Form : TCustomForm;
begin
TASPage(PageList[Index]).Free;
PageList.Delete(Index);
NoteBook.PageIndex := 0;

if csDesigning in NoteBook.ComponentState then
begin
Form := GetParentForm(NoteBook);
if (Form <> nil) and (Form.Designer <> nil) then
Form.Designer.Modified;
end;
end;

procedure TASPageAccess.Insert(Index: Integer; const S: string);
var
Page : TASPage;
Form : TCustomForm;
begin
Page := TASPage.Create(Notebook);
with Page do
begin
Parent := Notebook;
Caption := S;
end;
PageList.Insert(Index, Page);

NoteBook.PageIndex := Index;

if csDesigning in NoteBook.ComponentState then
begin
Form := GetParentForm(NoteBook);
if (Form <> nil) and (Form.Designer <> nil) then
Form.Designer.Modified;
end;
end;

procedure TASPageAccess.Move(CurIndex, NewIndex: Integer);
var
AObject : TObject;
begin
if CurIndex <> NewIndex then
begin
AObject := PageList[CurIndex];
PageList[CurIndex] := PageList[NewIndex];
PageList[NewIndex] := AObject;
NoteBook.PageIndex := NewIndex;
end;
end;

{ TASPage }

constructor TASPage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Visible := False;
ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible,
csParentBackground];
end;

procedure TASPage.Paint;
begin
inherited Paint;
Canvas.Brush.Color := TASPageControl(Owner).Color;
Canvas.FillRect(ClientRect);
end;

procedure TASPage.ReadState(Reader: TReader);
begin
if Reader.Parent is TASPageControl then
TASPageControl(Reader.Parent).FPageList.Add(Self);
inherited ReadState(Reader);
end;

procedure TASPage.WMNCHitTest(var Message: TWMNCHitTest);
begin
if not (csDesigning in ComponentState) then
Message.Result := HTTRANSPARENT
else
inherited;
end;

{ TASPageControl }

var
Registered : Boolean = False;

constructor TASPageControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 150;
Height := 150;
FNavigationWidth := 100;
FPageList := TList.Create;
FAccess := TASPageAccess.Create(FPageList, Self);
FPageIndex := -1;
//
FAccess.Add('默认页面');
PageIndex := 0;
//
Exclude(FComponentStyle, csInheritable);
//
FNavigation3D := True;

//
Self.Color := $00BEE9EB;
FNavigationColor := $00408000;

DoubleBuffered := True;
FBufferBMP := TBitmap.Create;
////////////
FNavigationFont := TFont.Create;
FNavigationFont.Color := clWhite;
FNavigationFont.Style := [fsBold];
FNavigationAcitveFont := TFont.Create;
FNavigationAcitveFont.Color := clBlack;
FNavigationAcitveFont.Style := [fsBold];
//////////////
ControlStyle := ControlStyle + [csParentBackground];

if not Registered then
begin
Classes.RegisterClasses([TASPage]);
Registered := True;
end;
end;

destructor TASPageControl.Destroy;
begin
FBufferBMP.Free;
FAccess.Free;
FPageList.Free;
inherited Destroy;
end;

procedure TASPageControl.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style or WS_CLIPCHILDREN;
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;

function TASPageControl.GetChildOwner: TComponent;
begin
Result := Self;
end;

procedure TASPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
I : Integer;
begin
for I := 0 to FPageList.Count - 1 do
Proc(TControl(FPageList));
end;

procedure TASPageControl.ReadState(Reader: TReader);
begin
Pages.Clear;
inherited ReadState(Reader);
if (FPageIndex <> -1) and (FPageIndex >= 0) and (FPageIndex < FPageList.Count)
then
with TASPage(FPageList[FPageIndex]) do
begin
BringToFront;
Visible := True;
Left := FNavigationWidth;
Width := Self.Width - FNavigationWidth;
Top := 0;
Height := Self.Height;
end
else
FPageIndex := -1;
end;

procedure TASPageControl.ShowControl(AControl: TControl);
var
I : Integer;
begin
for I := 0 to FPageList.Count - 1 do
if FPageList = AControl then
begin
SeTASPageIndex(I);
Exit;
end;
inherited ShowControl(AControl);
end;

procedure TASPageControl.SeTASPages(Value: TStrings);
begin
FAccess.Assign(Value);
end;

procedure TASPageControl.SeTASPageIndex(Value: Integer);
var
ParentForm : TCustomForm;
begin
if csLoading in ComponentState then
begin
FPageIndex := Value;
Exit;
end;
if (Value <> FPageIndex) and (Value >= 0) and (Value < FPageList.Count) then
begin
ParentForm := GetParentForm(Self);
if ParentForm <> nil then
if ContainsControl(ParentForm.ActiveControl) then
ParentForm.ActiveControl := Self;
with TASPage(FPageList[Value]) do
begin
BringToFront;
Visible := True;
Left := FNavigationWidth;
Width := Self.Width - FNavigationWidth;
Top := 0;
Height := Self.Height;
end;
if (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then
TASPage(FPageList[FPageIndex]).Visible := False;
FPageIndex := Value;
if ParentForm <> nil then
if ParentForm.ActiveControl = Self then
SelectFirst;
if Assigned(FOnPageChanged) then
FOnPageChanged(Self);
end;
Invalidate;
end;

procedure TASPageControl.SetActivePage(const Value: string);
begin
SeTASPageIndex(FAccess.IndexOf(Value));
end;

function TASPageControl.GetActivePage: string;
begin
Result := FAccess[FPageIndex];
end;

procedure TASPageControl.SetNavigationAcitveFont(const Value: TFont);
begin
FNavigationAcitveFont.Assign(Value);
Invalidate;
end;

procedure TASPageControl.SetNavigationColor(const Value: TColor);
begin
FNavigationColor := Value;
Invalidate;
end;

procedure TASPageControl.SetNavigationFont(const Value: TFont);
begin
FNavigationFont.Assign(Value);
Invalidate;
end;

procedure TASPageControl.Paint;
var
ACanvas : TCanvas;
ARect : TRect;
NavigationHeight : Integer;
I : Integer;

procedure DrawNavigationText(AText: string; Font: TFont; ARect: TRect);
var
oldFont : TFont;
begin
OldFont := TFont.Create;
try
OldFont.Assign(ACanvas.Font);
ACanvas.Font := Font;
DrawText(ACanvas, AText, ARect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
ACanvas.Font := oldFont;
finally
OldFont.Free;
end;
end;

var

L, R : Integer;
NRect, BRect : TRect;
begin
inherited Paint();

FBufferBMP.Width := 0;
FBufferBMP.Height := 0;
FBufferBMP.Width := FNavigationWidth;
FBufferBMP.Height := Self.Height;
//
ACanvas := FBufferBMP.Canvas;

ACanvas.Lock;
try
ARect := Rect(0, 0, FNavigationWidth, Self.Height);
ACanvas.Brush.Color := Color;
ACanvas.FillRect(ARect);
if FAccess.Count = 0 then
Exit;
NavigationHeight := Self.Height div FAccess.Count;
ACanvas.Brush.Color := FNavigationColor;
for I := 0 to FAccess.Count - 1 do
begin
ARect := Rect(0, I * NavigationHeight, FNavigationWidth,
(I + 1) * NavigationHeight + 1);
if I = FPageIndex then
begin
ACanvas.Brush.Color := Color;
ACanvas.FillRect(ARect);
ACanvas.Brush.Color := FNavigationColor;
DrawNavigationText(FAccess, FNavigationAcitveFont, ARect);

end
else
begin
if FNavigation3D then
begin
DrawNavigationButtonFace(ACanvas, ARect, 1);
end
else
begin
ACanvas.FillRect(ARect);
ACanvas.Rectangle(ARect);
end;
DrawNavigationText(FAccess, FNavigationFont, ARect);
end;
if Assigned(FOnDrawNavigation) then
FOnDrawNavigation(Self, ACanvas, ARect, I = FPageIndex);
end;

NRect := Rect(0, 0, FNavigationWidth, Self.ClientHeight);
BRect := Rect(0, 0, FBufferBMP.Width, FBufferBMP.Height);
Self.Canvas.CopyRect(NRect, ACanvas, BRect);
finally
ACanvas.Unlock;
end;
end;

procedure TASPageControl.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
PageIndex := GeTASPageIndexFormPos(X, Y);
Invalidate;
end;

function TASPageControl.GeTASPageIndexFormPos(X, Y: Integer): Integer;
var
I : Integer;
ARect : TRect;
NavigationHeight : Integer;
begin
Result := FPageIndex;
if FAccess.Count = 0 then
Exit;
NavigationHeight := Self.Height div FAccess.Count;
for I := 0 to FAccess.Count - 1 do
begin
ARect := Rect(0, I * NavigationHeight, FNavigationWidth - 1,
(I + 1) * NavigationHeight);
if (X > ARect.Left) and (X < ARect.Right) and
(Y > ARect.Top) and (Y < ARect.Bottom) then
begin
Result := I;
Exit;
end;
end;
end;

procedure TASPageControl.WMSize(var Message: TWMSize);
begin
inherited;
if csLoading in ComponentState then
Exit;
if FPageList.Count > 0 then
begin
TASPage(FPageList[FPageIndex]).Left := FNavigationWidth;
TASPage(FPageList[FPageIndex]).Width := Width - FNavigationWidth;
TASPage(FPageList[FPageIndex]).Height := Height;
TASPage(FPageList[FPageIndex]).Top := 0;
Invalidate;
end;
end;

function TASPageControl.GeTASPageRect: TRect;
begin
Result := REct(TASPage(FPageList[PageIndex]).Left,
TASPage(FPageList[PageIndex]).Top,
TASPage(FPageList[PageIndex]).Left +
TASPage(FPageList[PageIndex]).Width,
TASPage(FPageList[PageIndex]).Top +
TASPage(FPageList[PageIndex]).Height);
end;

procedure TASPageControl.SetNavigationWidth(const Value: Integer);
begin
if FNavigationWidth <> Value then
begin
FNavigationWidth := Value;
if csLoading in ComponentState then
Exit;
TASPage(FPageList[PageIndex]).Left := Value;
TASPage(FPageList[PageIndex]).Width := Width - Value;
TASPage(FPageList[PageIndex]).Top := 0;
TASPage(FPageList[PageIndex]).Height := Height;
Invalidate;
end;
end;

procedure TASPageControl.WMLButtonDown(var Message: TWMLButtonDown);
begin
if (csDesigning in ComponentState) then
begin
PageIndex := GeTASPageIndexFormPos(Message.XPos, Message.YPos);
Invalidate;
end
else
begin
inherited;
end;
end;

procedure TASPageControl.SetNavigation3D(const Value: Boolean);
begin
if FNavigation3D <> Value then
begin
FNavigation3D := Value;
Invalidate;
end;
end;

end.
/////////////////////////

///////////所调用到的　UnitASBase　//////////////////

{*******************************************************
By wr960204 王锐

2004/8/8
*******************************************************}
unit UnitASBase;

interface
uses
Controls;

Type
TASBase = Class(TCustomControl)
private
FAbout:String;
function GetCurrentVer: Double;
public
property CurrentVer:Double read GetCurrentVer;
published
property About:String read FAbout write FAbout;
end;

implementation

{ TASBase }
Const
CurrentVer = 0.5;


function TASBase.GetCurrentVer: Double;
begin
Result := CurrentVer;
end;

end.
///////////////////////////////////////////

//////////////所调用到的 UnitASUtils /////////////////////

unit UnitASUtils;

interface
uses
Windows, Controls, Graphics, Classes, SysUtils;

function TextWidth(Canvas: TCanvas; AText: WideString; Flags: Integer = 0):
integer;
overload;
function TextHeight(Canvas: TCanvas; AText: WideString): integer; overload;

procedure FillRect(Canvas: TCanvas; Rect: TRect; Color: TColor); overload;

procedure FillRect(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer;
Color: TColor); overload;

function DrawText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag:
cardinal): integer; overload;

function DrawText(ACanvas: TCanvas; AText: WideString; X, Y: integer): integer;
overload;

function CurrencyFrameCellWidth(ACanvas: TCanvas): Integer;

function ChineseCurrencyText(AText: WideString; ACurrencySymbol: WideChar):
Widestring;

procedure DrawCurrencyFrame(ACanvas: TCanvas; ARect: TRect; Value:
Currency; CurrencySymbol: WideChar; DrawZeroValue: Boolean = False);

function IsWinNT: Boolean;

implementation

function IsWinNT: Boolean;
var
VI: TOSVersionInfo;
begin
VI.dwOSVersionInfoSize := SizeOf(VI);
GetVersionEx(VI);
Result := VI.dwPlatformId = VER_PLATFORM_WIN32_NT;
end;

function TextWidth(Canvas: TCanvas; AText: WideString; Flags: Integer = 0):
integer;
begin
Result := Canvas.TextWidth(AText);
end;

function TextHeight(Canvas: TCanvas; AText: WideString): integer;
begin
Result := Canvas.TextHeight(AText);
end;

procedure FillRect(Canvas: TCanvas; Rect: TRect; Color: TColor);
begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
Canvas.FillRect(Rect);
end;

procedure FillRect(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer;
Color: TColor); overload;
begin
FillRect(Canvas, Rect(ALeft, ATop, ARight, ABottom), Color);
end;

function DrawText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag:
cardinal): integer;
begin
Result := Windows.DrawTextW(ACanvas.Handle, PWideChar(AText),
Length(AText), Bounds, Flag);
end;

function DrawText(ACanvas: TCanvas; AText: WideString; X, Y: integer): integer;
var
R: TRect;
begin
R := Rect(X, Y, X + TextWidth(ACanvas, AText), Y + TextHeight(ACanvas,
AText));
Result := DrawText(ACanvas, AText, R, 0);
end;

function CurrencyFrameCellWidth(ACanvas: TCanvas): Integer;
var
I: Integer;
Tmp: Integer;
begin
Result := 0;
for I := 30 to 39 do
begin
Tmp := ACanvas.TextWidth(Char(I)) + 2;
if Result < Tmp then
Result := Tmp;
end;
end;

function ChineseCurrencyText(AText: WideString; ACurrencySymbol: WideChar):
Widestring;
var
TmpStr: WideString;
P: PWideChar;
CurrValue: Currency;
begin
Result := '';
if not TryStrToCurr(AText, CurrValue) then
CurrValue := 0;
TmpStr := FormatFloat('0.00', Abs(CurrValue));
P := PWideChar(TmpStr);
while P^ <> WideChar(#0) do
begin
if P^ <> WideChar('.') then
Result := Result + P^;
Inc(P);
end;
Result := ACurrencySymbol + Result;
end;

procedure DrawCurrencyFrame(ACanvas: TCanvas; ARect: TRect; Value:
Currency; CurrencySymbol: WideChar; DrawZeroValue: Boolean = False);
const
//CurrencySymbol = '￥';
DecimalNumber = 2;
DigitalNumber = 10;
DecimalSeparatorColor = clRed;
KilobitSeparatorColor = clBlack;
GridLineColor = clMoneyGreen;
GridLineWidth = 1;
var
I: Integer;
RectWidth, RectHeight: Integer;
CX, CY: Integer;
LineNum: Integer;
IsNegative: Boolean; //是否是负数
AText: WideString;
CellWidth: Integer;
CharRect: TRect;
PCurrentChar: PWideChar;
OldFontColor: TColor;
DrawEnd: Boolean;
begin
OldFontColor := ACanvas.Font.Color;
//ShowMessage(IntToStr(ACanvas.Font.Size));
//CellWidth := ACanvas.TextWidth('0') + 2;
CellWidth := CurrencyFrameCellWidth(ACanvas);
IsNegative := (Value < 0);
AText := CurrencySymbol + FormatFloat('0.00', Value);
RectWidth := ARect.Right - ARect.Left;
RectHeight := ARect.Bottom - ARect.Top;
CX := ARect.Right - CellWidth;
CY := 0;
LineNum := -2;
PCurrentChar := @(AText[length(AText)]);
DrawEnd := False;
while CX > 0 do
begin
Inc(LineNum);
if (Value <> 0)or(DrawZeroValue) then
begin
CharRect := Rect(CX + GridLineWidth, CY, CX + CellWidth, CY + RectHeight);
if IsNegative then //负数是红色的；正数是黑色的
ACanvas.Font.Color := clRed
else
ACanvas.Font.Color := clBlack;

if not DrawEnd then
begin
DrawTextW(ACanvas.Handle, PCurrentChar, 1, CharRect, DT_SINGLELINE or
DT_CENTER or DT_VCENTER);
if PCurrentChar^ = CurrencySymbol then //划到了货币符号以后就不画字符了
DrawEnd := true;
end;
end;
if LineNum = 0 then
ACanvas.Pen.Color := DecimalSeparatorColor
else
if (LineNum mod 3) = 0 then
ACanvas.Pen.Color := KilobitSeparatorColor
else
ACanvas.Pen.Color := GridLineColor;
ACanvas.MoveTo(CX, CY);
ACanvas.LineTo(CX, CY + RectHeight);
Dec(CX, CellWidth);
Dec(PCurrentChar);
if (PCurrentChar^ = Widechar('.'))
or (PCurrentChar^ = Widechar('-')) then //跳过小数点、负号不画
Dec(PCurrentChar);
end;
ACanvas.Font.Color := OldFontColor;
end;

end.

///////////////////////////////////

备注：我写过信给作者，到现在还没回复。
 
H

hotboys

Unregistered / Unconfirmed
GUEST, unregistred user!
無法正常顯示字體的話就改改字體名字羅
 
G

gyh75

Unregistered / Unconfirmed
GUEST, unregistred user!
Font.Charset = GB2312_CHARSET
Font.Name = '宋体'
 
M

missinwind

Unregistered / Unconfirmed
GUEST, unregistred user!
换成标准通用的试试。
 
L

Lu_JR

Unregistered / Unconfirmed
GUEST, unregistred user!
上面朋友的建议我都试过了，还是不行，你们可以到　www.delphibox.com　下下载那控件试试！
 
C

cst_zf

Unregistered / Unconfirmed
GUEST, unregistred user!
宋体的大小我自己用确实是不一样的
你设成Fixedsys试试吧
我自己做是用了两套字体，判断操作系统然后选用合适的
 
您必须登录或注册才可回复。

Similar threads

I
图像旋转控件
回复
0
查看
563
import
I
I
DLL的数据共享
回复
0
查看
664
import
I
I
渐进色字体的标签
回复
0
查看
450
import
I
I
一个热键控件
回复
0
查看
601
import
I
I
Create a Scroll Box with Bitmap Background
回复
0
查看
719
import
I
顶部