paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-14 10:39:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: improved TFont for XLFD font names

Browse Source 
git-svn-id: trunk@1724 -
This commit is contained in:
lazarus 2002-06-04 15:17:26 +00:00
parent f62a94062d
commit 3a28d7a551
21 changed files with 1076 additions and 338 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
components/synedit/synedit.pp
View File

@ -3132,8 +3132,11 @@ var
Metrics: TTextMetric; Metrics: TTextMetric;
AveCW, MaxCW: Integer; AveCW, MaxCW: Integer;
begin begin
writeln('TCustomSynEdit.SetFont--------------------------------------------');
writeln(' TCustomSynEdit.SetFont A1',Value.Name);
DC := GetDC(0); DC := GetDC(0);
Save := SelectObject(DC, Value.Handle); Save := SelectObject(DC, Value.Handle);
writeln(' TCustomSynEdit.SetFont A2',Value.Name);
GetTextMetrics(DC, Metrics); GetTextMetrics(DC, Metrics);
SelectObject(DC, Save); SelectObject(DC, Save);
ReleaseDC(0, DC); ReleaseDC(0, DC);
@ -3141,6 +3144,7 @@ begin
AveCW := tmAveCharWidth; AveCW := tmAveCharWidth;
MaxCW := tmMaxCharWidth; MaxCW := tmMaxCharWidth;
end; end;
writeln(' TCustomSynEdit.SetFont B ',AveCW,',',MaxCW,' ',Value.Name);
case AveCW = MaxCW of case AveCW = MaxCW of
True: inherited Font := Value; True: inherited Font := Value;
False: False:
@ -3151,9 +3155,13 @@ begin
Size := Value.Size; Size := Value.Size;
Style := Value.Style; Style := Value.Style;
end; end;
writeln(' TCustomSynEdit.SetFont C ',AveCW,',',MaxCW,' ',Value.Name,
' Value.Size=',Value.Size,' Value.Height=',Value.Height,' DummyHeight=',fFontDummy.Height);
inherited Font := fFontDummy; inherited Font := fFontDummy;
end; end;
end; end;
writeln(' TCustomSynEdit.SetFont D ',Font.Name);
writeln('SSS1 "',Font.Name,'" Height=',Font.Height,' AveCW=',AveCW,' MaxCW=',MaxCW);
if fGutter.ShowLineNumbers then GutterChanged(Self); if fGutter.ShowLineNumbers then GutterChanged(Self);
end; end;

28
ide/editoroptions.pp
View File

@ -397,7 +397,7 @@ type
// form // form
procedure EditorOptionsFormResize(Sender: TObject); procedure EditorOptionsFormResize(Sender: TObject);
// general // general
procedure GeneralCheckBoxOnClick(Sender: TObject); procedure GeneralCheckBoxOnClick(Sender: TObject);
procedure ComboBoxOnChange(Sender:TObject); procedure ComboBoxOnChange(Sender:TObject);
@ -406,6 +406,7 @@ type
procedure ColorButtonColorChanged(Sender:TObject); procedure ColorButtonColorChanged(Sender:TObject);
// display // display
procedure FontDialogApplyClicked(Sender: TObject);
procedure EditorFontButtonClick(Sender:TObject); procedure EditorFontButtonClick(Sender:TObject);
// key mapping // key mapping
@ -2264,20 +2265,29 @@ begin
end; end;
end; end;
procedure TEditorOptionsForm.FontDialogApplyClicked(Sender: TObject);
var a: integer;
begin
for a:=Low(PreviewEdits) to High(PreviewEdits) do begin
if PreviewEdits[a]<>nil then
PreviewEdits[a].Font.Assign(TFontDialog(Sender).Font);
end;
EditorFontComboBox.Text:=DisplayPreview.Font.Name;
SetComboBoxText(EditorFontHeightComboBox,
IntToStr(DisplayPreview.Font.Height));
end;
procedure TEditorOptionsForm.EditorFontButtonClick(Sender:TObject); procedure TEditorOptionsForm.EditorFontButtonClick(Sender:TObject);
var FontDialog:TFontDialog; var
a:integer; FontDialog:TFontDialog;
begin begin
FontDialog:=TFontDialog.Create(Application); FontDialog:=TFontDialog.Create(Application);
try try
with FontDialog do begin with FontDialog do begin
Options:=Options+[fdApplyButton];
OnApplyClicked:=@FontDialogApplyClicked;
if Execute then begin if Execute then begin
EditorFontComboBox.Text:=FontName; FontDialogApplyClicked(FontDialog);
for a:=Low(PreviewEdits) to High(PreviewEdits) do begin
if PreviewEdits[a]<>nil then
FontDialogNameToFont(FontName,PreviewEdits[a].Font);
end;
EditorFontComboBox.Text:=PreviewEdits[a].Font.Name;
end; end;
end; end;
finally finally

39
ide/main.pp
View File

@ -44,16 +44,17 @@ uses
{$ENDIF} {$ENDIF}
Classes, LazarusIDEStrConsts, LCLType, LclLinux, Compiler, StdCtrls, Forms, Classes, LazarusIDEStrConsts, LCLType, LclLinux, Compiler, StdCtrls, Forms,
Buttons, Menus, ComCtrls, Spin, Project, SysUtils, FileCtrl, Controls, Buttons, Menus, ComCtrls, Spin, Project, SysUtils, FileCtrl, Controls,
Graphics, ExtCtrls, Dialogs, LazConf, CompReg, CodeToolManager, CodeCache, Graphics, GraphType, ExtCtrls, Dialogs, LazConf, CompReg, CodeToolManager,
DefineTemplates, MsgView, NewProjectDlg, IDEComp, AbstractFormEditor, CodeCache, DefineTemplates, MsgView, NewProjectDlg, IDEComp,
Designer, FormEditor, CustomFormEditor, ObjectInspector, PropEdits, AbstractFormEditor, Designer, FormEditor, CustomFormEditor, ObjectInspector,
ControlSelection, UnitEditor, CompilerOptions, EditorOptions, EnvironmentOpts, PropEdits, ControlSelection, UnitEditor, CompilerOptions, EditorOptions,
TransferMacros, SynEditKeyCmds, KeyMapping, ProjectOpts, IDEProcs, Process, EnvironmentOpts, TransferMacros, SynEditKeyCmds, KeyMapping, ProjectOpts,
UnitInfoDlg, Debugger, DBGOutputForm, GDBMIDebugger, RunParamsOpts, IDEProcs, Process, UnitInfoDlg, Debugger, DBGOutputForm, GDBMIDebugger,
ExtToolDialog, MacroPromptDlg, LMessages, ProjectDefs, Watchesdlg, RunParamsOpts, ExtToolDialog, MacroPromptDlg, LMessages, ProjectDefs,
BreakPointsdlg, ColumnDlg, OutputFilter, BuildLazDialog, MiscOptions, Watchesdlg, BreakPointsdlg, ColumnDlg, OutputFilter, BuildLazDialog,
EditDefineTree, CodeToolsOptions, TypInfo, IDEOptionDefs, CodeToolsDefines, MiscOptions, EditDefineTree, CodeToolsOptions, TypInfo, IDEOptionDefs,
LocalsDlg, DebuggerDlg, InputHistory, CodeToolsDefines, LocalsDlg, DebuggerDlg, InputHistory,
// main ide
BaseDebugManager, DebugManager, MainBar; BaseDebugManager, DebugManager, MainBar;
type type
@ -784,13 +785,15 @@ var
begin begin
pnlSpeedButtons := TPanel.Create(Self); pnlSpeedButtons := TPanel.Create(Self);
pnlSpeedButtons.Parent:= Self;
with pnlSpeedButtons do begin with pnlSpeedButtons do begin
Visible := True;
Name := 'pnlSpeedButtons'; Name := 'pnlSpeedButtons';
Parent:= Self;
Top := 0; Top := 0;
Left:= 0; Left:= 0;
Caption:= ''; Caption:= '';
BevelWidth:=1;
BevelOuter:=bvRaised;
Visible := True;
end; end;
@ -822,8 +825,8 @@ begin
StepIntoSpeedButton := CreateButton('StepIntoSpeedButton' , 'btn_stepinto' , 1, ButtonLeft, ButtonTop, [mfLeft], @mnuStepIntoProjectClicked, lsiHintStepInto); StepIntoSpeedButton := CreateButton('StepIntoSpeedButton' , 'btn_stepinto' , 1, ButtonLeft, ButtonTop, [mfLeft], @mnuStepIntoProjectClicked, lsiHintStepInto);
StepOverSpeedButton := CreateButton('StepOverpeedButton' , 'btn_stepover' , 1, ButtonLeft, ButtonTop, [mfLeft, mfTop], @mnuStepOverProjectClicked, lsiHintStepOver); StepOverSpeedButton := CreateButton('StepOverpeedButton' , 'btn_stepover' , 1, ButtonLeft, ButtonTop, [mfLeft, mfTop], @mnuStepOverProjectClicked, lsiHintStepOver);
pnlSpeedButtons.Width := ButtonLeft+1; pnlSpeedButtons.Width := ButtonLeft+3;
pnlSpeedButtons.Height := ButtonTop+1; pnlSpeedButtons.Height := ButtonTop+3;
// create the popupmenu for the OpenFileArrowSpeedBtn // create the popupmenu for the OpenFileArrowSpeedBtn
@ -845,7 +848,7 @@ begin
with ComponentNotebook do begin with ComponentNotebook do begin
Parent := Self; Parent := Self;
Name := 'ComponentNotebook'; Name := 'ComponentNotebook';
Left := ToggleFormSpeedBtn.Left + ToggleFormSpeedBtn.Width + 4; Left := ToggleFormSpeedBtn.Left + ToggleFormSpeedBtn.Width + 2;
Top := 0; Top := 0;
Width := Self.ClientWidth - Left; Width := Self.ClientWidth - Left;
Height := 60; //Self.ClientHeight - ComponentNotebook.Top; Height := 60; //Self.ClientHeight - ComponentNotebook.Top;
@ -978,11 +981,12 @@ begin
SourceNotebook.OnDeleteLastJumpPoint := @OnSrcNotebookDeleteLastJumPoint; SourceNotebook.OnDeleteLastJumpPoint := @OnSrcNotebookDeleteLastJumPoint;
SourceNotebook.OnEditorVisibleChanged := @OnSrcNotebookEditorVisibleChanged; SourceNotebook.OnEditorVisibleChanged := @OnSrcNotebookEditorVisibleChanged;
SourceNotebook.OnEditorChanged := @OnSrcNotebookEditorChanged; SourceNotebook.OnEditorChanged := @OnSrcNotebookEditorChanged;
SourceNotebook.OnEditorPropertiesClicked := @mnuEnvEditorOptionsClicked;
SourceNotebook.OnFindDeclarationClicked := @OnSrcNotebookFindDeclaration;
SourceNotebook.OnJumpToHistoryPoint := @OnSrcNotebookJumpToHistoryPoint; SourceNotebook.OnJumpToHistoryPoint := @OnSrcNotebookJumpToHistoryPoint;
SourceNotebook.OnNewClicked := @OnSrcNotebookFileNew; SourceNotebook.OnNewClicked := @OnSrcNotebookFileNew;
SourceNotebook.OnOpenClicked := @OnSrcNotebookFileOpen; SourceNotebook.OnOpenClicked := @OnSrcNotebookFileOpen;
SourceNotebook.OnOpenFileAtCursorClicked := @OnSrcNotebookFileOpenAtCursor; SourceNotebook.OnOpenFileAtCursorClicked := @OnSrcNotebookFileOpenAtCursor;
SourceNotebook.OnFindDeclarationClicked := @OnSrcNotebookFindDeclaration;
SourceNotebook.OnProcessUserCommand := @OnSrcNotebookProcessCommand; SourceNotebook.OnProcessUserCommand := @OnSrcNotebookProcessCommand;
SourceNotebook.OnSaveClicked := @OnSrcNotebookFileSave; SourceNotebook.OnSaveClicked := @OnSrcNotebookFileSave;
SourceNotebook.OnSaveAsClicked := @OnSrcNotebookFileSaveAs; SourceNotebook.OnSaveAsClicked := @OnSrcNotebookFileSaveAs;
@ -6404,6 +6408,9 @@ end.
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.306 2002/06/04 15:17:17 lazarus
MG: improved TFont for XLFD font names
Revision 1.305 2002/06/01 08:41:27 lazarus Revision 1.305 2002/06/01 08:41:27 lazarus
MG: DrawFramControl now uses gtk style, transparent STrechBlt MG: DrawFramControl now uses gtk style, transparent STrechBlt

34
ide/uniteditor.pp
View File

@ -282,15 +282,17 @@ type
FProcessingCommand: boolean; FProcessingCommand: boolean;
FOnAddJumpPoint: TOnAddJumpPoint; FOnAddJumpPoint: TOnAddJumpPoint;
FOnAddWatchAtCursor: TNotifyEvent;
FOnCloseClicked: TNotifyEvent; FOnCloseClicked: TNotifyEvent;
FOnDeleteLastJumpPoint: TNotifyEvent; FOnDeleteLastJumpPoint: TNotifyEvent;
FOnEditorVisibleChanged: TNotifyEvent; FOnEditorVisibleChanged: TNotifyEvent;
FOnEditorChanged: TNotifyEvent; FOnEditorChanged: TNotifyEvent;
FOnEditorPropertiesClicked: TNotifyEvent;
FOnFindDeclarationClicked: TNotifyEvent;
FOnJumpToHistoryPoint: TOnJumpToHistoryPoint; FOnJumpToHistoryPoint: TOnJumpToHistoryPoint;
FOnNewClicked: TNotifyEvent; FOnNewClicked: TNotifyEvent;
FOnOpenClicked: TNotifyEvent; FOnOpenClicked: TNotifyEvent;
FOnOpenFileAtCursorClicked: TNotifyEvent; FOnOpenFileAtCursorClicked: TNotifyEvent;
FOnFindDeclarationClicked: TNotifyEvent;
FOnProcessUserCommand: TOnProcessUserCommand; FOnProcessUserCommand: TOnProcessUserCommand;
FOnSaveAsClicked: TNotifyEvent; FOnSaveAsClicked: TNotifyEvent;
FOnSaveAllClicked: TNotifyEvent; FOnSaveAllClicked: TNotifyEvent;
@ -299,8 +301,7 @@ type
FOnToggleFormUnitClicked : TNotifyEvent; FOnToggleFormUnitClicked : TNotifyEvent;
FOnUserCommandProcessed: TOnProcessUserCommand; FOnUserCommandProcessed: TOnProcessUserCommand;
FOnViewJumpHistory: TNotifyEvent; FOnViewJumpHistory: TNotifyEvent;
FOnAddWatchAtCursor: TNotifyEvent;
FOnCreateBreakPoint: TOnCreateDeleteBreakPoint; FOnCreateBreakPoint: TOnCreateDeleteBreakPoint;
FOnDeleteBreakPoint: TOnCreateDeleteBreakPoint; FOnDeleteBreakPoint: TOnCreateDeleteBreakPoint;
@ -320,6 +321,7 @@ type
Procedure BookmarkGoTo(Value: Integer); Procedure BookmarkGoTo(Value: Integer);
Procedure BookMarkSet(Value : Integer); Procedure BookMarkSet(Value : Integer);
Procedure BookMarkToggle(Value : Integer); Procedure BookMarkToggle(Value : Integer);
procedure EditorPropertiesClicked(Sender: TObject);
Procedure BreakPointCreated(Sender : TObject; Line : Integer); Procedure BreakPointCreated(Sender : TObject; Line : Integer);
Procedure BreakPointDeleted(Sender : TObject; Line : Integer); Procedure BreakPointDeleted(Sender : TObject; Line : Integer);
@ -445,15 +447,17 @@ type
read FOnEditorVisibleChanged write FOnEditorVisibleChanged; read FOnEditorVisibleChanged write FOnEditorVisibleChanged;
property OnEditorChanged: TNotifyEvent property OnEditorChanged: TNotifyEvent
read FOnEditorChanged write FOnEditorChanged; read FOnEditorChanged write FOnEditorChanged;
property OnEditorPropertiesClicked: TNotifyEvent
read FOnEditorPropertiesClicked write FOnEditorPropertiesClicked;
property OnFindDeclarationClicked : TNotifyEvent
read FOnFindDeclarationClicked write FOnFindDeclarationClicked;
property OnJumpToHistoryPoint: TOnJumpToHistoryPoint property OnJumpToHistoryPoint: TOnJumpToHistoryPoint
read FOnJumpToHistoryPoint write FOnJumpToHistoryPoint; read FOnJumpToHistoryPoint write FOnJumpToHistoryPoint;
property OnNewClicked : TNotifyEvent read FOnNewClicked write FOnNewClicked; property OnNewClicked : TNotifyEvent read FOnNewClicked write FOnNewClicked;
property OnOpenClicked : TNotifyEvent read FOnOPenClicked write FOnOpenClicked; property OnOpenClicked : TNotifyEvent read FOnOPenClicked write FOnOpenClicked;
property OnOpenFileAtCursorClicked : TNotifyEvent property OnOpenFileAtCursorClicked : TNotifyEvent
read FOnOpenFileAtCursorClicked write FOnOpenFileAtCursorClicked; read FOnOpenFileAtCursorClicked write FOnOpenFileAtCursorClicked;
property OnFindDeclarationClicked : TNotifyEvent property OnSaveAsClicked : TNotifyEvent
read FOnFindDeclarationClicked write FOnFindDeclarationClicked;
property OnSaveAsClicked : TNotifyEvent
read FOnSaveAsClicked write FOnSaveAsClicked; read FOnSaveAsClicked write FOnSaveAsClicked;
property OnSaveAllClicked : TNotifyEvent property OnSaveAllClicked : TNotifyEvent
read FOnSaveAllClicked write FOnSaveAllClicked; read FOnSaveAllClicked write FOnSaveAllClicked;
@ -2214,6 +2218,12 @@ begin
FUnUsedEditorComponents.Clear; FUnUsedEditorComponents.Clear;
end; end;
procedure TSourceNotebook.EditorPropertiesClicked(Sender: TObject);
begin
if Assigned(FOnEditorPropertiesClicked) then
FOnEditorPropertiesClicked(Sender);
end;
Procedure TSourceNotebook.BuildPopupMenu; Procedure TSourceNotebook.BuildPopupMenu;
Function Seperator : TMenuItem; Function Seperator : TMenuItem;
@ -2288,6 +2298,12 @@ Begin
MenuItem.OnClick := @ReadOnlyClicked; MenuItem.OnClick := @ReadOnlyClicked;
SrcPopupMenu.Items.Add(MenuItem); SrcPopupMenu.Items.Add(MenuItem);
MenuItem := TMenuItem.Create(Self);
MenuItem.Name := 'ShowLineNumbersMenuItem';
MenuItem.Caption := 'Show Line Numbers';
menuItem.OnClick := @ToggleLineNumbersClicked;
SrcPopupMenu.Items.Add(MenuItem);
SrcPopupMenu.Items.Add(Seperator); SrcPopupMenu.Items.Add(Seperator);
MenuItem := TMenuItem.Create(Self); MenuItem := TMenuItem.Create(Self);
@ -2324,9 +2340,9 @@ Begin
SrcPopupMenu.Items.Add(Seperator); SrcPopupMenu.Items.Add(Seperator);
MenuItem := TMenuItem.Create(Self); MenuItem := TMenuItem.Create(Self);
MenuItem.Name := 'ShowLineNumbersMenuItem'; MenuItem.Name := 'EditorPropertiesMenuItem';
MenuItem.Caption := 'Show Line Numbers'; MenuItem.Caption := 'Editor properties';
menuItem.OnClick := @ToggleLineNumbersClicked; MenuItem.OnClick :=@EditorPropertiesClicked;
SrcPopupMenu.Items.Add(MenuItem); SrcPopupMenu.Items.Add(MenuItem);
end; end;

37
lcl/dialogs.pp
View File

@ -36,7 +36,7 @@ unit Dialogs;
interface interface
uses Classes, Forms, Controls, VCLGlobals, LMessages; uses Classes, Forms, Controls, VCLGlobals, LMessages, Graphics;
//type //type
// TDialogButtons = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, // TDialogButtons = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry,
@ -195,13 +195,34 @@ type
{ TFontDialog } { TFontDialog }
TFontDialogOption = (fdAnsiOnly, fdTrueTypeOnly, fdEffects,
fdFixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts,
fdNoSimulations, fdNoSizeSel, fdNoStyleSel, fdNoVectorFonts,
fdShowHelp, fdWysiwyg, fdLimitSize, fdScalableOnly, fdApplyButton);
TFontDialogOptions = set of TFontDialogOption;
TFontDialog = class(TCommonDialog) TFontDialog = class(TCommonDialog)
private private
FFontName : String; FFont: TFont;
FMaxFontSize: Integer;
FMinFontSize: Integer;
FOnApplyClicked: TNotifyEvent;
FOptions: TFontDialogOptions;
FPreviewText: string;
procedure SetFont(const AValue: TFont);
public public
procedure ApplyClicked; virtual;
constructor Create (AOwner : TComponent); override; constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
published published
property FontName : String read FFontName write FFontName; property Font: TFont read FFont write SetFont;
property MinFontSize: Integer read FMinFontSize write FMinFontSize;
property MaxFontSize: Integer read FMaxFontSize write FMaxFontSize;
property Options: TFontDialogOptions
read FOptions write FOptions default [fdEffects];
property OnApplyClicked: TNotifyEvent
read FOnApplyClicked write FOnApplyClicked;
property PreviewText: string read FPreviewText write FPreviewText;
end; end;
@ -227,7 +248,7 @@ implementation
uses uses
Buttons, StdCtrls, LCLlinux, Graphics, SysUtils, FileCtrl; Buttons, StdCtrls, LCLlinux, SysUtils, FileCtrl;
resourcestring resourcestring
rsMbYes = 'Yes'; rsMbYes = 'Yes';
@ -269,6 +290,11 @@ var
{$I commondialog.inc} {$I commondialog.inc}
{$I filedialog.inc} {$I filedialog.inc}
{$I colordialog.inc} {$I colordialog.inc}
procedure TFontDialog.SetFont(const AValue: TFont);
begin
FFont.Assign(AValue);
end;
{$I fontdialog.inc} {$I fontdialog.inc}
{$I messagedialogpixmaps.inc} {$I messagedialogpixmaps.inc}
{$I messagedialogs.inc} {$I messagedialogs.inc}
@ -305,6 +331,9 @@ end.
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.14 2002/06/04 15:17:21 lazarus
MG: improved TFont for XLFD font names
Revision 1.13 2002/05/30 14:11:11 lazarus Revision 1.13 2002/05/30 14:11:11 lazarus
MG: added filters and history to TOpenDialog MG: added filters and history to TOpenDialog

90
lcl/graphics.pp
View File

@ -119,6 +119,8 @@ type
TBitmap = class; TBitmap = class;
TPixmap = class; TPixmap = class;
TIcon = class; TIcon = class;
{ TGraphicsObject }
TGraphicsObject = class(TPersistent) TGraphicsObject = class(TPersistent)
private private
@ -133,6 +135,8 @@ type
end; end;
{ TFont }
TFont = class(TGraphicsObject) TFont = class(TGraphicsObject)
private private
FColor : TColor; FColor : TColor;
@ -144,25 +148,39 @@ type
//--------- //---------
FFontData: TFontData; FFontData: TFontData;
FPixelsPerInch: Integer; FPixelsPerInch: Integer;
FFontName: string;
FUpdateCount: integer;
FChanged: boolean;
procedure FreeHandle; procedure FreeHandle;
Protected procedure GetData(var FontData: TFontData);
function GetHandle: HFONT; procedure SetData(const FontData: TFontData);
procedure SetHandle(const Value: HFONT); protected
Procedure SetName(const value : TFontName); procedure Changed; override;
Function GetName : TFontName; function GetCharSet: TFontCharSet;
Procedure SetSize(value : Integer); function GetHandle: HFONT;
Procedure SetHeight(value : Integer); function GetHeight: Integer;
Function GetSize : Integer; function GetName : TFontName;
procedure SetStyle(Value: TFontStyles); function GetPitch: TFontPitch;
Procedure SetPitch(Value : TFontPitch); function GetSize : Integer;
public function GetStyle: TFontStyles;
procedure Assign(Source : TPersistent); override; procedure SetCharSet(const AValue: TFontCharSet);
procedure SetColor(Value : TColor); procedure SetColor(Value : TColor);
procedure SetHandle(const Value: HFONT);
procedure SetHeight(value : Integer);
procedure SetName(const AValue : TFontName);
procedure SetPitch(Value : TFontPitch);
procedure SetSize(value : Integer);
procedure SetStyle(Value: TFontStyles);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source : TPersistent); override;
procedure Assign(const ALogFont: TLogFont);
procedure BeginUpdate;
procedure EndUpdate;
// Extra properties // Extra properties
// TODO: implement them though GetTextMetrics, not here // TODO: implement them though GetTextMetrics, not here
//Function GetWidth(Value : String) : Integer; //Function GetWidth(Value : String) : Integer;
constructor Create;
destructor Destroy; override;
// Extra properties // Extra properties
// TODO: implement them though GetTextMetrics, not here // TODO: implement them though GetTextMetrics, not here
//property Width : Integer read FWidth write FWidth; //property Width : Integer read FWidth write FWidth;
@ -172,15 +190,18 @@ type
property Handle : HFONT read GetHandle write SetHandle; property Handle : HFONT read GetHandle write SetHandle;
property PixelsPerInch : Integer read FPixelsPerInch; property PixelsPerInch : Integer read FPixelsPerInch;
published published
property CharSet: TFontCharSet read GetCharSet write SetCharSet;
property Color : TColor read FColor write SetColor; property Color : TColor read FColor write SetColor;
property Height : Integer read FFontData.Height write SetHeight; property Height : Integer read GetHeight write SetHeight;
property Name : TFontName read GetName write SetName; property Name : TFontName read GetName write SetName;
property Pitch: TFontPitch read FFontData.Pitch write SetPitch; property Pitch: TFontPitch read GetPitch write SetPitch;
property Size: Integer read GetSize write SetSize; property Size: Integer read GetSize write SetSize;
property Style : TFontStyles read FFontData.Style write SetStyle; property Style : TFontStyles read GetStyle write SetStyle;
end; end;
{ TPen }
TPen = class(TGraphicsObject) TPen = class(TGraphicsObject)
private private
FPenData : TPenData; FPenData : TPenData;
@ -206,6 +227,8 @@ type
end; end;
{ TBrush }
TBrushData = record TBrushData = record
Handle : HBrush; Handle : HBrush;
Color : TColor; Color : TColor;
@ -405,6 +428,8 @@ type
EInvalidGraphic = class(Exception); EInvalidGraphic = class(Exception);
{ TCanvas }
TCanvas = class(TPersistent) TCanvas = class(TPersistent)
private private
FAutoReDraw : Boolean; FAutoReDraw : Boolean;
@ -474,9 +499,9 @@ type
Procedure MoveTo(X1,Y1 : Integer); Procedure MoveTo(X1,Y1 : Integer);
Procedure LineTo(X1,Y1 : Integer); Procedure LineTo(X1,Y1 : Integer);
procedure TextOut(X,Y: Integer; const Text: String); procedure TextOut(X,Y: Integer; const Text: String);
procedure TextRect(Rect: TRect; X, Y: integer; const Text : string);// overload; procedure TextRect(Rect: TRect; X, Y: integer; const Text : string);
procedure TextRect(Rect: TRect; X, Y: integer; const Text : string; procedure TextRect(Rect: TRect; X, Y: integer; const Text : string;
const Style : TTextStyle); //overload; const Style : TTextStyle);
function TextExtent(const Text: string): TSize; function TextExtent(const Text: string): TSize;
function TextHeight(const Text: string): Integer; function TextHeight(const Text: string): Integer;
function TextWidth(const Text: string): Integer; function TextWidth(const Text: string): Integer;
@ -498,7 +523,8 @@ type
property Color: TColor read GetColor write SetColor; property Color: TColor read GetColor write SetColor;
end; end;
{TBITMAP}
{ TBITMAP }
TSharedImage = class TSharedImage = class
private private
@ -579,6 +605,7 @@ type
property TransparentColor: TColor read FTransparentColor write FTransparentColor; property TransparentColor: TColor read FTransparentColor write FTransparentColor;
end; end;
{ TPixmap } { TPixmap }
{ {
@abstract() @abstract()
@ -620,11 +647,29 @@ function ColorToString(Color: TColor): AnsiString;
function StringToColor(const S: shortstring): TColor; function StringToColor(const S: shortstring): TColor;
procedure GetColorValues(Proc: TGetColorStringProc); procedure GetColorValues(Proc: TGetColorStringProc);
procedure GetCharsetValues(Proc: TGetStrProc);
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
function GetDefFontCharSet: TFontCharSet;
function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean;
function XLFDNameToLogFont(const XLFDName: string): TLogFont;
function ExtractFamilyFromXLFDName(const XLFDName: string): string;
var var
{ Stores information about the current screen } { Stores information about the current screen }
ScreenInfo : TLMScreenInit; ScreenInfo : TLMScreenInit;
const // New TFont instances are initialized with the values in this structure:
DefFontData: TFontData = (
Handle: 0;
Height: 0;
Pitch: fpDefault;
Style: [];
Charset : DEFAULT_CHARSET;
Name: 'default');
(*************************************************************************** (***************************************************************************
***************************************************************************) ***************************************************************************)
implementation implementation
@ -765,6 +810,9 @@ end.
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.32 2002/06/04 15:17:21 lazarus
MG: improved TFont for XLFD font names
Revision 1.31 2002/06/01 08:41:28 lazarus Revision 1.31 2002/06/01 08:41:28 lazarus
MG: DrawFramControl now uses gtk style, transparent STrechBlt MG: DrawFramControl now uses gtk style, transparent STrechBlt

7
lcl/graphtype.pp
View File

@ -38,10 +38,10 @@ type
TColor = longint; //Also defined in LMessages.pp TColor = longint; //Also defined in LMessages.pp
TFontPitch = (fpDefault, fpVariable, fpFixed); TFontPitch = (fpDefault, fpVariable, fpFixed);
TFontName = shortstring; TFontName = string;
TFontStyle = (fsBold, fsItalic, fsStrikeOut, fsUnderline);
TFontCharSet = 0..255; TFontCharSet = 0..255;
TFontDataName = string[LF_FACESIZE -1]; TFontDataName = string[LF_FACESIZE -1];
TFontStyle = (fsBold, fsItalic, fsStrikeOut, fsUnderline);
TFontStyles = set of TFontStyle; TFontStyles = set of TFontStyle;
TFontStylesbase = set of TFontStyle; TFontStylesbase = set of TFontStyle;
@ -145,6 +145,9 @@ end.
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.4 2002/06/04 15:17:21 lazarus
MG: improved TFont for XLFD font names
Revision 1.3 2002/05/10 06:05:50 lazarus Revision 1.3 2002/05/10 06:05:50 lazarus
MG: changed license to LGPL MG: changed license to LGPL

4
lcl/include/bevel.inc
View File

@ -78,6 +78,7 @@ Begin
End; End;
End; End;
Canvas.Pen.Width:=1; Canvas.Pen.Width:=1;
Case Shape Of Case Shape Of
bsBox: bsBox:
With Canvas Do With Canvas Do
@ -244,6 +245,9 @@ End;
{ {
$Log$ $Log$
Revision 1.6 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.5 2002/05/10 06:05:51 lazarus Revision 1.5 2002/05/10 06:05:51 lazarus
MG: changed license to LGPL MG: changed license to LGPL

17
lcl/include/canvas.inc
View File

@ -493,19 +493,11 @@ end;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
procedure TCanvas.TextOut(X,Y: Integer; const Text: String); procedure TCanvas.TextOut(X,Y: Integer; const Text: String);
var
pStr: PChar;
begin begin
RequiredState([csHandleValid, csFontValid, csBrushValid]); RequiredState([csHandleValid, csFontValid, csBrushValid]);
ExtTextOut(FHandle, X, Y, 0 { <-- TODO: FTextFlags}, nil,
pStr := StrAlloc(Length(Text)+1); PChar(Text), Length(Text), nil);
try MoveTo(X + TextWidth(Text), Y);
StrPcopy(pStr, Text);
ExtTextOut(FHandle, X, Y, 0 { <-- TODO: FTextFlags}, nil, pStr, Length(Text), nil);
MoveTo(X + TextWidth(Text), Y);
finally
StrDispose(PStr);
end;
end; end;
@ -842,6 +834,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.19 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.18 2002/05/10 06:05:51 lazarus Revision 1.18 2002/05/10 06:05:51 lazarus
MG: changed license to LGPL MG: changed license to LGPL

17
lcl/include/custompanel.inc
View File

@ -87,22 +87,21 @@ end;
procedure TCustomPanel.Paint; procedure TCustomPanel.Paint;
var var
Rect: TRect; ARect: TRect;
TS : TTextStyle; TS : TTextStyle;
begin begin
Rect := GetClientRect; ARect := GetClientRect;
if BorderStyle = bsSingle then begin if BorderStyle = bsSingle then begin
Canvas.Rectangle(Rect); Canvas.Rectangle(ARect);
InflateRect(Rect, -1, -1); InflateRect(ARect, -1, -1);
end; end;
if BevelOuter <> bvNone then if BevelOuter <> bvNone then
Canvas.Frame3d(Rect, BevelWidth, BevelOuter); Canvas.Frame3d(ARect, BevelWidth, BevelOuter);
if BevelInner <> bvNone then begin if BevelInner <> bvNone then begin
if BorderWidth > 0 then InflateRect(Rect, -BorderWidth, -BorderWidth); if BorderWidth > 0 then InflateRect(ARect, -BorderWidth, -BorderWidth);
Canvas.Frame3d(Rect, BevelWidth, BevelInner); Canvas.Frame3d(ARect, BorderWidth, BevelInner);
end; end;
if Caption <> '' then begin if Caption <> '' then begin
@ -110,7 +109,7 @@ begin
TS.Layout:= tlCenter; TS.Layout:= tlCenter;
TS.Opaque:= false; TS.Opaque:= false;
TS.Clipping:= false; TS.Clipping:= false;
Canvas.TextRect(Rect, 0, 0, Caption, TS); Canvas.TextRect(ARect, 0, 0, Caption, TS);
end; end;
end; end;

492
lcl/include/font.inc
View File

@ -1,3 +1,4 @@
// included by graphics.pp
{****************************************************************************** {******************************************************************************
TFONT TFONT
****************************************************************************** ******************************************************************************
@ -16,6 +17,303 @@
***************************************************************************** *****************************************************************************
} }
const
FontCharsets: array[0..17] of TIdentMapEntry = (
(Value: ANSI_CHARSET; Name: 'ANSI_CHARSET'),
(Value: DEFAULT_CHARSET; Name: 'DEFAULT_CHARSET'),
(Value: SYMBOL_CHARSET; Name: 'SYMBOL_CHARSET'),
(Value: MAC_CHARSET; Name: 'MAC_CHARSET'),
(Value: SHIFTJIS_CHARSET; Name: 'SHIFTJIS_CHARSET'),
(Value: HANGEUL_CHARSET; Name: 'HANGEUL_CHARSET'),
(Value: JOHAB_CHARSET; Name: 'JOHAB_CHARSET'),
(Value: GB2312_CHARSET; Name: 'GB2312_CHARSET'),
(Value: CHINESEBIG5_CHARSET; Name: 'CHINESEBIG5_CHARSET'),
(Value: GREEK_CHARSET; Name: 'GREEK_CHARSET'),
(Value: TURKISH_CHARSET; Name: 'TURKISH_CHARSET'),
(Value: HEBREW_CHARSET; Name: 'HEBREW_CHARSET'),
(Value: ARABIC_CHARSET; Name: 'ARABIC_CHARSET'),
(Value: BALTIC_CHARSET; Name: 'BALTIC_CHARSET'),
(Value: RUSSIAN_CHARSET; Name: 'RUSSIAN_CHARSET'),
(Value: THAI_CHARSET; Name: 'THAI_CHARSET'),
(Value: EASTEUROPE_CHARSET; Name: 'EASTEUROPE_CHARSET'),
(Value: OEM_CHARSET; Name: 'OEM_CHARSET'));
procedure GetCharsetValues(Proc: TGetStrProc);
var
I: Integer;
begin
for I:=Low(FontCharsets) to High(FontCharsets) do
Proc(FontCharsets[I].Name);
end;
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
begin
Result:=IntToIdent(Charset, Ident, FontCharsets);
end;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
begin
Result:=IdentToInt(Ident, CharSet, FontCharsets);
end;
function GetFontData(Font: HFont): TFontData;
var
ALogFont: TLogFont;
begin
Result := DefFontData;
if Font <> 0 then
begin
if GetObject(Font, SizeOf(ALogFont), @ALogFont) <> 0 then
with Result, ALogFont do
begin
Height := lfHeight;
if lfWeight >= FW_BOLD then
Include(Style, fsBold);
if lfItalic = 1 then
Include(Style, fsItalic);
if lfUnderline = 1 then
Include(Style, fsUnderline);
if lfStrikeOut = 1 then
Include(Style, fsStrikeOut);
Charset := TFontCharset(lfCharSet);
Name := lfFaceName;
case lfPitchAndFamily and $F of
VARIABLE_PITCH: Pitch := fpVariable;
FIXED_PITCH: Pitch := fpFixed;
else
Pitch := fpDefault;
end;
Handle := Font;
end;
end;
end;
function GetDefFontCharSet: TFontCharSet;
//var
// DisplayDC: HDC;
// TxtMetric: TTEXTMETRIC;
begin
Result := DEFAULT_CHARSET;
{DisplayDC := GetDC(0);
if (DisplayDC <> 0) then begin
if (SelectObject(DisplayDC, StockFont) <> 0) then
if (GetTextMetrics(DisplayDC, TxtMetric)) then
Result := TxtMetric.tmCharSet;
ReleaseDC(0, DisplayDC);
end;}
end;
{------------------------------------------------------------------------------
Method: ExtractFamilyFromXLFDName
Params: const XLFDName: string
Returns: string
Parses a font name in XLFD format and extracts the FamilyName.
(see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html)
An XLFD name is
FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName
-AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing
-AverageWidth-CharSetRegistry-CharSetCoding
------------------------------------------------------------------------------}
function ExtractFamilyFromXLFDName(const XLFDName: string): string;
var StartPos, EndPos, i: integer;
begin
Result:='';
StartPos:=1;
i:=0;
while (StartPos<=length(XLFDName)) do begin
if XLFDName[StartPos]='-' then begin
inc(i);
if i=2 then begin
inc(StartPos);
EndPos:=StartPos;
while (EndPos<=length(XLFDName)) and (XLFDName[EndPos]<>'-') do
inc(EndPos);
Result:=copy(XLFDName,StartPos,EndPos-StartPos);
end;
end;
inc(StartPos);
end;
end;
{------------------------------------------------------------------------------
Method: XLFDNameToLogFont
Params: const XLFDName: string
Returns: TLogFont
Parses a font name in XLFD format and creates a TLogFont record from it.
(see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html)
An XLFD name is
FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName
-AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing
-AverageWidth-CharSetRegistry-CharSetCoding
------------------------------------------------------------------------------}
function XLFDNameToLogFont(const XLFDName: string): TLogFont;
type
TWeightMapEntry = record
Name: string;
Weight: integer;
end;
const
WeightMap: array[1..15] of TWeightMapEntry = (
(Name: 'DONTCARE'; Weight: FW_DONTCARE),
(Name: 'THIN'; Weight: FW_THIN),
(Name: 'EXTRALIGHT'; Weight: FW_EXTRALIGHT),
(Name: 'LIGHT'; Weight: FW_LIGHT),
(Name: 'NORMAL'; Weight: FW_NORMAL),
(Name: 'MEDIUM'; Weight: FW_MEDIUM),
(Name: 'SEMIBOLD'; Weight: FW_SEMIBOLD),
(Name: 'BOLD'; Weight: FW_BOLD),
(Name: 'EXTRABOLD'; Weight: FW_EXTRABOLD),
(Name: 'HEAVY'; Weight: FW_HEAVY),
(Name: 'ULTRALIGHT'; Weight: FW_ULTRALIGHT),
(Name: 'REGULAR'; Weight: FW_REGULAR),
(Name: 'DEMIBOLD'; Weight: FW_DEMIBOLD),
(Name: 'ULTRABOLD'; Weight: FW_ULTRABOLD),
(Name: 'BLACK'; Weight: FW_BLACK)
);
var
ItemStart, ItemEnd: integer;
Item: string;
procedure GetNextItem;
begin
ItemStart:=ItemEnd+1;
ItemEnd:=ItemStart;
while (ItemEnd<=length(XLFDName)) and (XLFDName[ItemEnd]<>'-') do
inc(ItemEnd);
Item:=copy(XLFDName,ItemStart,ItemEnd-ItemStart);
end;
function WeightNameToWeightID(const WeightName: string): integer;
var i: integer;
begin
for i:=Low(WeightMap) to High(WeightMap) do begin
if AnsiCompareText(WeightMap[i].Name,WeightName)=0 then begin
Result:=WeightMap[i].Weight;
exit;
end;
end;
Result:=FW_DONTCARE;
end;
var l, FaceNameMax, PixelSize, PointSize, Resolution: integer;
begin
FillChar(Result,SizeOf(TLogFont),0);
ItemEnd:=0;
GetNextItem; // read FontNameRegistry
// ToDo
GetNextItem; // read Foundry
// ToDo
GetNextItem; // read FamilyName
l:=length(Item);
FaceNameMax:=High(Result.lfFaceName)-Low(Result.lfFaceName); // max without #0
if l>FaceNameMax then l:=FaceNameMax;
if l>0 then Move(Item[1],Result.lfFaceName[Low(Result.lfFaceName)],l);
Result.lfFaceName[Low(Result.lfFaceName)+l]:=#0;
GetNextItem; // read WeightName
Result.lfWeight:=WeightNameToWeightID(Item);
GetNextItem; // read Slant
if (AnsiCompareText(Item,'I')=0) or (AnsiCompareText(Item,'RI')=0)
or (AnsiCompareText(Item,'O')=0) then
// I = italic, RI = reverse italic, O = oblique
Result.lfItalic:=1
else
Result.lfItalic:=0;
GetNextItem; // read SetwidthName
// ToDO: NORMAL, CONDENSED, NARROW, WIDE, EXPANDED
GetNextItem; // read AddStyleName
// calculate Style name extentions (=rotation)
// API XLFD
// --------------------- --------------
// Orientation 1/10 deg 1/64 deg
Result.lfOrientation:=(StrToIntDef(Item,0)*10) div 64;
GetNextItem; // read PixelSize
PixelSize:=StrToIntDef(Item,0);
GetNextItem; // read PointSize
PointSize:=StrToIntDef(Item,0) div 10;
GetNextItem; // read ResolutionX
Resolution:=StrToIntDef(Item,0);
if Resolution<=0 then Resolution:=72;
if PixelSize=0 then begin
if PointSize<=0 then
Result.lfHeight:=(12*Resolution) div 72
else
Result.lfHeight:=(PointSize*Resolution) div 72;
end else begin
Result.lfHeight:=PixelSize;
end;
GetNextItem; // read ResolutionY
Resolution:=StrToIntDef(Item,0);
if Resolution<=0 then Resolution:=72;
if PixelSize=0 then begin
if PointSize<=0 then
Result.lfWidth:=(12*Resolution) div 72
else
Result.lfWidth:=(PointSize*Resolution) div 72;
end else begin
Result.lfWidth:=PixelSize;
end;
GetNextItem; // read Spacing
// ToDo
{M Monospaced (fixed pitch)
P Proportional spaced (variable pitch)
C Character cell. The glyphs of the font can be thought of as
"boxes" of the same width and height that are stacked side by
side or top to bottom.}
GetNextItem; // read AverageWidth
// ToDo
GetNextItem; // read CharSetRegistry
// ToDo
GetNextItem; // read CharSetCoding
// ToDo
end;
{------------------------------------------------------------------------------
Method: IsFontNameXLogicalFontDesc
Params: const LongFontName: string
Returns: boolean
Checks if font name is in X Logical Font Description format.
(see http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html)
An XLFD name is
FontNameRegistry-Foundry-FamilyName-WeightName-Slant-SetwidthName
-AddStyleName-PixelSize-PointSize-ResolutionX-ResolutionY-Spacing
-AverageWidth-CharSetRegistry-CharSetCoding
------------------------------------------------------------------------------}
function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean;
// Quick test: check if LongFontName contains 14 times the char '-'
var MinusCnt, p: integer;
begin
MinusCnt:=0;
for p:=1 to length(LongFontName) do
if LongFontName[p]='-' then inc(MinusCnt);
Result:=(MinusCnt=14);
end;
{ TFont }
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Method: TFont.Create Method: TFont.Create
@ -27,12 +325,7 @@
constructor TFont.Create; constructor TFont.Create;
begin begin
inherited Create; inherited Create;
with FFontData do FFontData:=DefFontData;
begin
Handle := 0;
Charset := ANSI_CHARSET;
Pitch := fpDefault;
end;
FColor := clWindowText; FColor := clWindowText;
FPixelsPerInch := ScreenInfo.PixelsPerInchX; FPixelsPerInch := ScreenInfo.PixelsPerInchX;
@ -52,9 +345,17 @@ begin
try try
//TODO: TFont(Source).Lock; //TODO: TFont(Source).Lock;
try try
Height := TFont(Source).Height; BeginUpdate;
Color := TFont(Source).Color; try
Name := TFont(Source).Name; CharSet:= TFont(Source).CharSet;
Color := TFont(Source).Color;
Height := TFont(Source).Height;
Name := TFont(Source).Name;
Pitch := TFont(Source).Pitch;
Style := TFont(Source).Style;
finally
EndUpdate;
end;
finally finally
//TODO: TFont(Source).UnLock; //TODO: TFont(Source).UnLock;
end; end;
@ -63,7 +364,53 @@ begin
end; end;
Exit; Exit;
end; end;
inherited Assign(Source);
inherited Assign(Source);
end;
{------------------------------------------------------------------------------
Method: TFont.Assign
Params: ALogFont: TLogFont
Returns: nothing
Copies the logfont settings to itself
------------------------------------------------------------------------------}
procedure TFont.Assign(const ALogFont: TLogFont);
var
AStyle: TFontStyles;
begin
BeginUpdate;
try
with ALogFont do
begin
Height := ALogFont.lfHeight;
Charset := TFontCharset(ALogFont.lfCharSet);
AStyle := [];
with ALogFont do
begin
if lfWeight >= FW_SEMIBOLD then Include(AStyle, fsBold);
if lfItalic <> 0 then Include(AStyle, fsItalic);
if lfUnderline <> 0 then Include(AStyle, fsUnderline);
if lfStrikeOut <> 0 then Include(AStyle, fsStrikeOut);
end;
Style := AStyle;
Name := ALogFont.lfFaceName;
end;
finally
EndUpdate;
end;
end;
procedure TFont.BeginUpdate;
begin
inc(FUpdateCount);
end;
procedure TFont.EndUpdate;
begin
if FUpdateCount=0 then exit;
dec(FUpdateCount);
if (FUpdateCount=0) and FChanged then Changed;
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -97,7 +444,7 @@ end;
Sets the pitch of a font Sets the pitch of a font
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
Procedure TFont.SetPitch(Value : TFOntPitch); Procedure TFont.SetPitch(Value : TFontPitch);
Begin Begin
if FFontData.Pitch <> Value if FFontData.Pitch <> Value
then begin then begin
@ -166,7 +513,10 @@ end;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TFont.GetName: TFontName; function TFont.GetName: TFontName;
begin begin
Result := FFontdata.Name; if FFontName<>'' then
Result:=FFontName
else
Result := FFontdata.Name;
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -176,12 +526,13 @@ end;
Sets the name of a font Sets the name of a font
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
procedure TFont.SetName(const Value : TFontName); procedure TFont.SetName(const AValue : TFontName);
begin begin
if FFontData.Name <> Value if FFontData.Name <> AValue
then begin then begin
FreeHandle; FreeHandle;
FFontData.Name := Value; FFontData.Name := AValue;
FFontName:=AValue;
Changed; Changed;
end; end;
end; end;
@ -208,13 +559,7 @@ end;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
procedure TFont.SetHandle(const Value: HFONT); procedure TFont.SetHandle(const Value: HFONT);
begin begin
if FFontData.Handle <> Value SetData(GetFontData(Value));
then begin
FreeHandle;
FFontData.Handle := Value;
//TODO: query new parameters
Changed;
end;
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -229,10 +574,25 @@ const
LF_BOOL: array[Boolean] of Byte = (0, 255); LF_BOOL: array[Boolean] of Byte = (0, 255);
LF_WEIGHT: array[Boolean] of Integer = (FW_NORMAL, FW_BOLD); LF_WEIGHT: array[Boolean] of Integer = (FW_NORMAL, FW_BOLD);
var var
LogFont: TLogFont; ALogFont: TLogFont;
procedure SetLogFontName(const NewName: string);
var l: integer;
aName: string;
begin
if IsFontNameXLogicalFontDesc(NewName) then
aName:=ExtractFamilyFromXLFDName(NewName)
else
aName:=NewName;
l:=High(ALogFont.lfFaceName)-Low(ALogFont.lfFaceName);
if l>length(aName) then l:=length(aName);
if l>0 then
Move(aName[1],ALogFont.lfFaceName[Low(ALogFont.lfFaceName)],l);
ALogFont.lfFaceName[Low(ALogFont.lfFaceName)+l]:=#0;
end;
begin begin
if FFontData.Handle = 0 if FFontData.Handle = 0 then with ALogFont do
then with LogFont do
begin begin
lfHeight := Height; lfHeight := Height;
lfWidth := 0; lfWidth := 0;
@ -243,14 +603,7 @@ begin
lfUnderline := LF_BOOL[fsUnderline in Style]; lfUnderline := LF_BOOL[fsUnderline in Style];
lfStrikeOut := LF_BOOL[fsStrikeOut in Style]; lfStrikeOut := LF_BOOL[fsStrikeOut in Style];
lfCharSet := Byte(FFontData.Charset); lfCharSet := Byte(FFontData.Charset);
if AnsiCompareText(Name, 'Default') = 0 SetLogFontName(Name);
then StrPCopy(lfFaceName, 'helvetica') //TODO: change this to a more flexible default
else begin
if length(Name)+1<=SizeOf(lfFaceName) then
StrPCopy(lfFaceName, Name)
else
StrPCopy(lfFaceName, LeftStr(Name,SizeOf(lfFaceName)-1));
end;
lfQuality := DEFAULT_QUALITY; lfQuality := DEFAULT_QUALITY;
lfOutPrecision := OUT_DEFAULT_PRECIS; lfOutPrecision := OUT_DEFAULT_PRECIS;
@ -262,7 +615,8 @@ begin
lfPitchAndFamily := DEFAULT_PITCH; lfPitchAndFamily := DEFAULT_PITCH;
end; end;
FFontData.Handle := CreateFontIndirect(LogFont); // ask the interface for the nearest font
FFontData.Handle := CreateFontIndirectEx(ALogFont,Name);
end; end;
Result := FFontData.Handle; Result := FFontData.Handle;
@ -285,10 +639,80 @@ begin
end; end;
end; end;
function TFont.GetCharSet: TFontCharSet;
begin
Result:=FFontData.CharSet;
end;
procedure TFont.SetCharSet(const AValue: TFontCharSet);
begin
if FFontData.CharSet <> AValue
then begin
FreeHandle;
FFontData.CharSet := AValue;
Changed;
end;
end;
procedure TFont.GetData(var FontData: TFontData);
begin
FontData := FFontData;
FontData.Handle := 0;
end;
procedure TFont.SetData(const FontData: TFontData);
begin
if FFontData.Handle <> FontData.Handle then begin
FreeHandle;
FFontData.Handle := FontData.Handle;
FFontName:=FontData.Name;
//TODO: query new parameters
Changed;
end;
{Lock;
try
FontManager.ChangeResource(Self, FontData);
finally
Unlock;
end;}
end;
function TFont.GetHeight: Integer;
begin
Result:=FFontData.Height;
end;
function TFont.GetPitch: TFontPitch;
begin
Result:=FFontData.Pitch;
end;
function TFont.GetStyle: TFontStyles;
begin
Result:=FFontData.Style;
end;
procedure TFont.Changed;
begin
if FUpdateCount>0 then begin
FChanged:=true;
exit;
end;
FChanged:=false;
inherited Changed;
// ToDo: we need interfaces:
// if FNotify <> nil then FNotify.Changed;
end;
// included by graphics.pp
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.6 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.5 2002/05/10 06:05:52 lazarus Revision 1.5 2002/05/10 06:05:52 lazarus
MG: changed license to LGPL MG: changed license to LGPL

29
lcl/include/fontdialog.inc
View File

@ -15,6 +15,18 @@
* * * *
***************************************************************************** *****************************************************************************
} }
{------------------------------------------------------------------------------
Method: TFontDialog.Apply
Params: Wnd: HWND
Returns: Nothing
Called whenever the Apply button is clicked.
------------------------------------------------------------------------------}
procedure TFontDialog.ApplyClicked;
begin
if Assigned(FOnApplyClicked) then FOnApplyClicked(Self);
end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Method: TFontDialog.Create Method: TFontDialog.Create
Params: AOwner: the owner of the class Params: AOwner: the owner of the class
@ -24,14 +36,25 @@
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
constructor TFontDialog.Create (AOwner : TComponent); constructor TFontDialog.Create (AOwner : TComponent);
begin begin
inherited Create(AOwner); inherited Create(AOwner);
fCompStyle := csFontDialog; fCompStyle := csFontDialog;
FTitle:= 'Select a font:'; FTitle:= 'Select a font:';
FFont := TFont.Create;
FOptions := [fdEffects];
end;
destructor TFontDialog.Destroy;
begin
FFont.Free;
inherited Destroy;
end; end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.3 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.2 2002/05/10 06:05:52 lazarus Revision 1.2 2002/05/10 06:05:52 lazarus
MG: changed license to LGPL MG: changed license to LGPL

14
lcl/include/statusbar.inc
View File

@ -1,3 +1,4 @@
// included by comctrls.pp
{ {
***************************************************************************** *****************************************************************************
* * * *
@ -23,7 +24,7 @@ begin
ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque]; ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque];
Color := clBtnFace; Color := clBtnFace;
Height := 19; Height := 19;
Setbounds(0,TWinControl(AOwner).Height-21,TWInControl(AOwner).Width,20); Setbounds(0,TWinControl(AOwner).Height-21,TWinControl(AOwner).Width,20);
Align := alBottom; Align := alBottom;
FPanels := TStatusPanels.Create(Self); FPanels := TStatusPanels.Create(Self);
FCanvas := TControlCanvas.Create; FCanvas := TControlCanvas.Create;
@ -135,16 +136,19 @@ Begin
For I := 0 to Panels.Count-1 do For I := 0 to Panels.Count-1 do
Begin Begin
if I = Panels.Count-1 then if I = Panels.Count-1 then
Panels[I].Width := ClientWidth-X; //this sets the last panel to the width of the statusbar // this sets the last panel to the width of the statusbar
Panels[I].Width := ClientWidth-X;
DrawBevel(X,I); DrawBevel(X,I);
Canvas.TextOut(X+2,Y+X2,Panels[i].Text); Canvas.TextOut(X+2,Y+X2,Panels[i].Text);
//draw divider //draw divider
if I < Panels.Count-1 then if I < Panels.Count-1 then
DrawDivider(X+Panels[i].Width); DrawDivider(X+Panels[i].Width);
inc(X); inc(X);
X := X + Panels[i].Width+1; X := X + Panels[i].Width+1;
end; end;
end end
else Canvas.TextOut(Left+2,Top+X2,SimpleText); else
Canvas.TextOut(Left+2,Top+X2,SimpleText);
End; End;
// included by comctrls.pp

10
lcl/include/winapi.inc
View File

@ -123,6 +123,12 @@ begin
Result := InterfaceObject.CreateFontIndirect(LogFont); Result := InterfaceObject.CreateFontIndirect(LogFont);
end; end;
function CreateFontIndirectEx(const LogFont: TLogFont;
const LongFontName: string): HFONT;
begin
Result := InterfaceObject.CreateFontIndirectEx(LogFont,LongFontName);
end;
function CreatePenIndirect(const LogPen: TLogPen): HPEN; function CreatePenIndirect(const LogPen: TLogPen): HPEN;
begin begin
Result := InterfaceObject.CreatePenIndirect(LogPen); Result := InterfaceObject.CreatePenIndirect(LogPen);
@ -667,6 +673,7 @@ function CreateFont(Height, Width, Escapement, Orientation, Weight: Integer;
var var
LogFont: TLogFont; LogFont: TLogFont;
begin begin
writeln('CreateFont Name="',FaceName,'"');
with LogFont do with LogFont do
begin begin
lfHeight := Height; lfHeight := Height;
@ -1129,6 +1136,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.32 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.31 2002/05/27 17:58:42 lazarus Revision 1.31 2002/05/27 17:58:42 lazarus
MG: added command line help MG: added command line help

4
lcl/include/winapih.inc
View File

@ -61,6 +61,7 @@ function CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; {$IFD
function CreateCompatibleDC(DC: HDC): HDC; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreateCompatibleDC(DC: HDC): HDC; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
//function CreateFont --> independent //function CreateFont --> independent
function CreateFontIndirect(const LogFont: TLogFont): HFONT; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreateFontIndirect(const LogFont: TLogFont): HFONT; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function CreateFontIndirectEx(const LogFont: TLogFont; const LongFontName: string): HFONT; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
//function CreatePen --> independent //function CreatePen --> independent
function CreatePenIndirect(const LogPen: TLogPen): HPEN; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreatePenIndirect(const LogPen: TLogPen): HPEN; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function CreatePixmapIndirect(const Data: Pointer; const TransColor: Longint): HBITMAP; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} function CreatePixmapIndirect(const Data: Pointer; const TransColor: Longint): HBITMAP; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -268,6 +269,9 @@ function UnionRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): Boolean
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.27 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.26 2002/05/27 17:58:42 lazarus Revision 1.26 2002/05/27 17:58:42 lazarus
MG: added command line help MG: added command line help

59
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -711,12 +711,16 @@ function gtkDialogOKclickedCB( widget: PGtkWidget;
var var
theDialog : TCommonDialog; theDialog : TCommonDialog;
Fpointer : Pointer; Fpointer : Pointer;
// colordialog
colorArray : array[0..2] of double; colorArray : array[0..2] of double;
colorsel : GTK_COLOR_SELECTION; colorsel : GTK_COLOR_SELECTION;
newColor : TGdkColor; newColor : TGdkColor;
// fontdialog
FontName : String; FontName : String;
ALogFont : TLogFont;
// filedialog
cListRow : PGList; cListRow : PGList;
rowNum : gint; rowNum : gint;
fileInfo : PGChar; fileInfo : PGChar;
fileList : PGTKCList; fileList : PGTKCList;
DirName : string; DirName : string;
@ -784,10 +788,18 @@ begin
end end
else if theDialog is TFontDialog then else if theDialog is TFontDialog then
begin begin
Assert(False, 'Trace:Prssed OK in FontDialog'); Assert(False, 'Trace:Pressed OK in FontDialog');
FontName := gtk_font_selection_dialog_get_font_name(pgtkfontselectiondialog(FPointer)); FontName := gtk_font_selection_dialog_get_font_name(
TFontDialog(theDialog).FontName := FontName; pgtkfontselectiondialog(FPointer));
Assert(False, 'Trace:-----'+TFontDialog(theDialog).FontName+'----'); // extract basic font attributes from the font name in XLFD format
ALogFont:=XLFDNameToLogFont(FontName);
TFontDialog(theDialog).Font.Assign(ALogFont);
// set the font name in XLFD format
// a font name in XLFD format overrides in the gtk interface all other font
// settings.
TFontDialog(theDialog).Font.Name := FontName;
Assert(False, 'Trace:-----'+TFontDialog(theDialog).Font.Name+'----');
end; end;
StoreCommonDialogSetup(theDialog); StoreCommonDialogSetup(theDialog);
@ -839,6 +851,40 @@ begin
end; end;
end; end;
{-------------------------------------------------------------------------------
function gtkDialogApplyclickedCB
Params: widget: PGtkWidget; data: gPointer
Result: GBoolean
This function is called, whenever the user clicks the Apply button in a
commondialog
-------------------------------------------------------------------------------}
function gtkDialogApplyclickedCB(widget: PGtkWidget; data: gPointer): GBoolean;
cdecl;
var
theDialog : TCommonDialog;
FontName: string;
ALogFont: TLogFont;
begin
Result := True;
theDialog := TCommonDialog(data);
// gtk_grab_remove(PgtkWidget(TCommonDialog(data).Handle));
if (theDialog is TFontDialog)
and (fdApplyButton in TFontDialog(theDialog).Options)
and (Assigned(TFontDialog(theDialog).OnApplyClicked)) then begin
// extract basic font attributes from the font name in XLFD format
FontName := gtk_font_selection_dialog_get_font_name(
pgtkfontselectiondialog(theDialog.Handle));
ALogFont:=XLFDNameToLogFont(FontName);
TFontDialog(theDialog).Font.Assign(ALogFont);
// set the font name in XLFD format
// a font name in XLFD format overrides in the gtk interface all other font
// settings.
TFontDialog(theDialog).Font.Name := FontName;
TFontDialog(theDialog).OnApplyClicked(theDialog);
end;
end;
{------------------------------------------------------------------------------- {-------------------------------------------------------------------------------
function gtkDialogCloseQueryCB function gtkDialogCloseQueryCB
Params: widget: PGtkWidget; data: gPointer Params: widget: PGtkWidget; data: gPointer
@ -1981,6 +2027,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.78 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.77 2002/05/30 14:11:12 lazarus Revision 1.77 2002/05/30 14:11:12 lazarus
MG: added filters and history to TOpenDialog MG: added filters and history to TOpenDialog

5
lcl/interfaces/gtk/gtkdef.pp
View File

@ -72,7 +72,7 @@ type
); );
gdiFont: ( gdiFont: (
GDIFontObject: PGdkFont; GDIFontObject: PGdkFont;
LogFont: TLogFont; // for now font info is stored as well, later query font params LogFont: TLogFont;// for now font info is stored as well, later query font params
); );
gdiPen: ( gdiPen: (
GDIPenColor: TGdkColor; GDIPenColor: TGdkColor;
@ -141,6 +141,9 @@ end.
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.8 2002/06/04 15:17:23 lazarus
MG: improved TFont for XLFD font names
Revision 1.7 2002/06/01 08:41:28 lazarus Revision 1.7 2002/06/01 08:41:28 lazarus
MG: DrawFramControl now uses gtk style, transparent STrechBlt MG: DrawFramControl now uses gtk style, transparent STrechBlt

433
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -1042,12 +1042,25 @@ end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Function: CreateFontIndirect Function: CreateFontIndirect
Params: none Params: const LogFont: TLogFont
Returns: Nothing Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TgtkObject.CreateFontIndirect(const LogFont: TLogFont): HFONT; function TgtkObject.CreateFontIndirect(const LogFont: TLogFont): HFONT;
begin
Result:=CreateFontIndirectEx(LogFont,'');
end;
{------------------------------------------------------------------------------
Function: CreateFontIndirectEx
Params: const LogFont: TLogFont; const LongFontName: string
Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------}
function TgtkObject.CreateFontIndirectEx(const LogFont: TLogFont;
const LongFontName: string): HFONT;
var var
GdiObject: PGdiObject; GdiObject: PGdiObject;
S: String; S: String;
@ -1058,8 +1071,6 @@ var
n: Integer; n: Integer;
procedure LoadFont; procedure LoadFont;
var
pStr: PChar;
begin begin
S := Format('%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s', S := Format('%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s',
[FontNameRegistry, Foundry, FamilyName, WeightName, [FontNameRegistry, Foundry, FamilyName, WeightName,
@ -1068,172 +1079,224 @@ var
CharSetRegistry, CharSetCoding CharSetRegistry, CharSetCoding
]); ]);
pStr := StrAlloc(Length(S) + 1); //writeln(' Trying "',S,'"');
try GdiObject^.GDIFontObject := gdk_font_load(PChar(s));
StrPCopy(pStr, S); end;
GdiObject^.GDIFontObject := gdk_font_load(pStr);
finally procedure LoadDefaultFont;
StrDispose(pStr); begin
end; FGDIObjects.Remove(GdiObject);
Dispose(GdiObject);
GdiObject:=CreateDefaultFont;
end; end;
begin begin
// For info about xlfd see: http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html // For info about xlfd see:
// http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html
// Lets fill in all the xlfd parts. Assume we have scalable fonts // Lets fill in all the xlfd parts. Assume we have scalable fonts
Result := 0; Result := 0;
GDIObject := NewGDIObject(gdiFont);
with LogFont do try
begin GdiObject^.LogFont := LogFont;
//writeln('TgtkObject.CreateFontIndirectEx Name="',LogFont.lfFaceName,'"',
//' Long="',LongFontName,'" ',IsFontNameXLogicalFontDesc(LongFontName)
//,' ',ord(LogFont.lfFaceName[0]));
S:=LongFontName;
if IsFontNameXLogicalFontDesc(LongFontName) then begin
GdiObject^.GDIFontObject := gdk_font_load(PChar(LongFontName));
if GdiObject^.GDIFontObject<>nil then begin
GdiObject^.LogFont := XLFDNameToLogFont(LongFontName);
exit;
end;
end;
with LogFont do
begin
FontNameRegistry := ''; FontNameRegistry := '';
Foundry := '*'; Foundry := '*';
if lfFaceName[0] = #0 if lfFaceName[0] = #0
then begin then begin
Assert(false,'ERROR: [TgtkObject.CreateFontIndirect] No fontname'); Assert(false,'ERROR: [TgtkObject.CreateFontIndirectEx] No fontname');
Exit; Exit;
end;
FamilyName := StrPas(lfFaceName); //StringReplace(FaceName, ' ', '*');
if AnsiCompareText(FamilyName,'default')=0 then begin
LoadDefaultFont;
exit;
end;
Assert(False, Format('trace: [TgtkObject.CreateFontIndirectEx] Name: %s, Height: %d', [FamilyName, lfHeight]));
// calculate weight offset.
// API XLFD
// --------------------- --------------
// Weight=400 --> normal normal
// Weight=700 --> bold normal+4000 (or bold in non scalable fonts)
//
// So in API the offset for normal = 400 and an increase of 300 equals to
// an offset of 4000
case lfWeight of
FW_DONTCARE : WeightName := '*';
FW_LIGHT : WeightName := 'light';
FW_NORMAL : WeightName := 'normal';
FW_MEDIUM : WeightName := 'medium';
FW_SEMIBOLD : WeightName := 'demi bold';
FW_BOLD : WeightName := 'bold';
else begin
n := ((lfWeight - FW_NORMAL) * 4000) div (FW_BOLD - FW_NORMAL);
if n = 0
then WeightName := 'normal'
else if n > 0
then WeightName := Format('normal+%d', [n])
else WeightName := Format('normal%d', [n]);
end;
end;
// TODO: find out if escapement has something to do with slant
if lfItalic = 0 then Slant := 'r' else Slant := 'i';
SetwidthName := '*';
// calculate Style name extentions (=rotation)
// API XLFD
// --------------------- --------------
// Orientation 1/10 deg 1/64 deg
if lfOrientation = 0
then AddStyleName := '*'
else begin
n := (lfOrientation * 64) div 10;
if n >= 0
then AddStyleName := Format('+%d', [n])
else AddStyleName := Format('+%d', [n]);
end;
// TODO: make more accurate (implement the meaning of
// positive and negative heigtht values.
PixelSize := IntToStr(Abs(lfHeight));
// Since we use pixelsize, it isn't allowed to give a value here
PointSize := '*';
// Use the default
ResolutionX := '*';
ResolutionY := '*';
Spacing := '*';
// calculate AverageWidth
// API XLFD
// --------------------- --------------
// Width pixel 1/10 pixel
if lfWidth = 0
then AverageWidth := '*'
else AverageWidth := InttoStr(lfWidth * 10);
CharSetRegistry := '*';
// TODO: Match charset.
CharSetCoding := '*';
end; end;
FamilyName := StrPas(lfFaceName); //StringReplace(FaceName, ' ', '*'); //write('CreateFontIndirect->');
LoadFont;
Assert(False, Format('trace: [TgtkObject.CreateFontIndirect] Name: %s, Height: %d', [FamilyName, lfHeight])); if GdiObject^.GDIFontObject = nil
then begin
// calculate weight offset. if (WeightName='normal') then begin
// API XLFD WeightName:='medium';
// --------------------- -------------- LoadFont;
// Weight=400 --> normal normal end else if (WeightName='bold') then begin
// Weight=700 --> bold normal+4000 (or bold in non scalable fonts) WeightName:='black';
// LoadFont;
// So in API the offset for normal = 400 and an increase of 300 equals to
// an offset of 4000
case lfWeight of
0: WeightName := '*';
FW_NORMAL: WeightName := 'normal';
FW_MEDIUM: WeightName := 'medium';
FW_BOLD: WeightName := 'bold';
FW_BLACK: WeightName := 'black';
else begin
n := ((lfWeight - FW_NORMAL) * 4000) div (FW_BOLD - FW_NORMAL);
if n = 0
then WeightName := 'normal'
else if n > 0
then WeightName := Format('normal+%d', [n])
else WeightName := Format('normal%d', [n]);
end; end;
end; end;
// TODO: find out if escapement has something to do with slant if GdiObject^.GDIFontObject = nil
if lfItalic = 0 then Slant := 'r' else Slant := 'i'; then begin
if (WeightName='medium') then begin
SetwidthName := '*'; WeightName:='regular';
LoadFont;
// calculate Style name extentions (=rotation) end else if (WeightName='black') then begin
// API XLFD WeightName:='demi bold';
// --------------------- -------------- LoadFont;
// Orientation 1/10 deg 1/64 deg end;
if lfOrientation = 0
then AddStyleName := '*'
else begin
n := (lfOrientation * 64) div 10;
if n >= 0
then AddStyleName := Format('+%d', [n])
else AddStyleName := Format('+%d', [n]);
end; end;
// TODO: make more accurate (implement the meaning of if GdiObject^.GDIFontObject = nil
// positive and negative heigtht values. then begin
PixelSize := IntToStr(Abs(lfHeight)); // try all weights
WeightName := '*';
// Since we use pixelsize, it isn't allowed to give a value here
PointSize := '*';
// Use the default
ResolutionX := '*';
ResolutionY := '*';
Spacing := '*';
// calculate AverageWidth
// API XLFD
// --------------------- --------------
// Widht pixel 1/10 pixel
if lfWidth = 0
then AverageWidth := '*'
else AverageWidth := InttoStr(lfWidth * 10);
CharSetRegistry := '*';
// TODO: Match charset.
CharSetCoding := '*';
end;
//write('CreateFontIndirect->');
GDIObject := NewGDIObject(gdiFont);
LoadFont;
if GdiObject^.GDIFontObject = nil
then begin
if (WeightName='normal') then begin
WeightName:='medium';
LoadFont;
end else if (WeightName='bold') then begin
WeightName:='black';
LoadFont; LoadFont;
end; end;
end;
if GdiObject^.GDIFontObject = nil // try instead of italic oblique
then begin if GdiObject^.GDIFontObject = nil
// try all weights then begin
WeightName := '*'; if (Slant='i') then begin
LoadFont; Slant := 'o';
end; LoadFont;
end;
if GdiObject^.GDIFontObject = nil end;
then begin
// try all weights
WeightName := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all slant // try all slant
Slant := '*'; if GdiObject^.GDIFontObject = nil
LoadFont; then begin
end; Slant := '*';
LoadFont;
end;
// try one height lower
if GdiObject^.GDIFontObject = nil
then begin
PixelSize := IntToStr(Abs(LogFont.lfHeight)-1);
LoadFont;
end;
// try one height higher
if GdiObject^.GDIFontObject = nil
then begin
PixelSize := IntToStr(Abs(LogFont.lfHeight)+1);
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all Familys // try all Familys
FamilyName := '*'; if GdiObject^.GDIFontObject = nil
LoadFont; then begin
end; PixelSize := IntToStr(Abs(LogFont.lfHeight));
FamilyName := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil
then begin
// try all Foundrys // try all Foundrys
Foundry := '*'; if GdiObject^.GDIFontObject = nil
LoadFont; then begin
end; Foundry := '*';
LoadFont;
end;
if GdiObject^.GDIFontObject = nil finally
then begin if GdiObject^.GDIFontObject = nil
//writeln('[TgtkObject.CreateFontIndirect] ',HexStr(Cardinal(GdiObject),8),' ',FGDIObjects.Count); then begin
FGDIObjects.Remove(GdiObject); //writeln('[TgtkObject.CreateFontIndirect] ',HexStr(Cardinal(GdiObject),8),' ',FGDIObjects.Count);
Dispose(GdiObject); FGDIObjects.Remove(GdiObject);
Result := 0; Dispose(GdiObject);
end Result := 0;
else begin end
GdiObject^.LogFont := LogFont; else begin
Result := HFONT(GdiObject); GdiObject^.LogFont := LogFont;
end; Result := HFONT(GdiObject);
end;
if Result = 0 if Result = 0
then WriteLn(Format('WARNING: [TgtkObject.CreateFontIndirect] NOT found XLFD: <%s>', [S])) then WriteLn(Format('WARNING: [TgtkObject.CreateFontIndirectEx] NOT found XLFD: <%s>', [S]))
else Assert(False, Format('Trace: [TgtkObject.CreateFontIndirect] found XLFD: <%s>', [S])); else Assert(False, Format('Trace: [TgtkObject.CreateFontIndirectEx] found XLFD: <%s>', [S]));
end;
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -1512,6 +1575,7 @@ begin
end; end;
DFC_MENU: DFC_MENU:
begin begin
end; end;
DFC_SCROLL: DFC_SCROLL:
begin begin
@ -1567,11 +1631,11 @@ end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Function: DrawEdge Function: DrawEdge
Params: Params: DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal
Returns: Returns: Boolean
Draws one or more edges of a rectangle, not including the Draws one or more edges of a rectangle. The rectangle is the area
right and bottom edge. Left to Right-1 and Top to Bottom-1.
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TgtkObject.DrawEdge(DC: HDC; var Rect: TRect; edge: Cardinal; function TgtkObject.DrawEdge(DC: HDC; var Rect: TRect; edge: Cardinal;
grfFlags: Cardinal): Boolean; grfFlags: Cardinal): Boolean;
@ -1597,6 +1661,7 @@ begin
Dec(R.Right); Dec(R.Right);
Dec(R.Bottom); Dec(R.Bottom);
// try to use the gdk functions, so that the current theme is used
BInner := False; BInner := False;
BOuter := False; BOuter := False;
@ -1912,8 +1977,12 @@ end;
Draws a 3d border in GTK native style. Draws a 3d border in GTK native style.
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TGtkObject.Frame3d(DC : HDC; var Rect : TRect; const FrameWidth : integer; const Style : TBevelCut) : boolean; function TGtkObject.Frame3d(DC : HDC; var Rect : TRect;
const GTKShadowType: array[TBevelCut] of integer = (GTK_SHADOW_NONE, GTK_SHADOW_IN, GTK_SHADOW_OUT); const FrameWidth : integer; const Style : TBevelCut) : boolean;
const GTKShadowType: array[TBevelCut] of integer =
(GTK_SHADOW_NONE, GTK_SHADOW_IN, GTK_SHADOW_OUT);
var Widget : TGtkWidget; var Widget : TGtkWidget;
i : integer; i : integer;
begin begin
@ -1928,13 +1997,14 @@ begin
Widget:=PGtkFixed(GetFixedWidget(PGtkWidget( Widget:=PGtkFixed(GetFixedWidget(PGtkWidget(
PDeviceContext(DC)^.hWnd)))^.Container.Widget; PDeviceContext(DC)^.hWnd)))^.Container.Widget;
for i:= 1 to FrameWidth do begin for i:= 1 to FrameWidth do begin
gtk_paint_shadow(Widget.thestyle, Widget.window, GTK_STATE_NORMAL, gtk_draw_shadow(Widget.thestyle, Widget.window, GTK_STATE_NORMAL,
GtkShadowType[Style], nil, @Widget, nil, GtkShadowType[Style],
Rect.left, Rect.top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top); Rect.left, Rect.top,
InflateRect(Rect, -1, -1); Rect.Right - Rect.Left-1, Rect.Bottom - Rect.Top-1);
InflateRect(Rect, -1, -1);
end;
end; end;
end; end;
end;
end; end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
@ -2333,12 +2403,16 @@ begin
end; end;
gdiFont: gdiFont:
begin begin
if Buf = nil then Result := SizeOf(PGDIObject(GDIObj)^.LogFont) if Buf = nil then
Result := SizeOf(PGDIObject(GDIObj)^.LogFont)
else begin else begin
if BufSize >= SizeOf(PGDIObject(GDIObj)^.LogFont) if BufSize >= SizeOf(PGDIObject(GDIObj)^.LogFont)
then begin then begin
PLogfont(Buf)^ := PGDIObject(GDIObj)^.LogFont; PLogfont(Buf)^ := PGDIObject(GDIObj)^.LogFont;
Result:= SizeOf(TLogFont); Result:= SizeOf(TLogFont);
end else if BufSize>0 then begin
Move(PGDIObject(GDIObj)^.LogFont,Buf^,BufSize);
Result:=BufSize;
end; end;
end; end;
end; end;
@ -2815,27 +2889,41 @@ end;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
function TgtkObject.GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean; function TgtkObject.GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean;
const
TestString = '{m|g_}';
AvrWidthStr = 'abcxyz012789 ';
var var
lbearing, rbearing, dummy: LongInt; lbearing, rbearing, dummy: LongInt;
AvrWidthStrLen: integer;
begin begin
Assert(False, Format('Trace:> TODO FINISH[TgtkObject.GetTextMetrics] DC: 0x%x', [DC])); Assert(False, Format('Trace:> TODO FINISH[TgtkObject.GetTextMetrics] DC: 0x%x', [DC]));
Result := IsValidDC(DC); Result := IsValidDC(DC);
if Result then with PDeviceContext(DC)^ do begin if Result then
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) with PDeviceContext(DC)^ do begin
then begin if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
WriteLn('WARNING: [TgtkObject.GetTGextMetrics] Missing font'); then begin
Result := False; WriteLn('WARNING: [TgtkObject.GetTGextMetrics] Missing font');
end Result := False;
else with TM do begin end
FillChar(TM, SizeOf(TM), 0); else with TM do begin
FillChar(TM, SizeOf(TM), 0);
gdk_text_extents(CurrentFont^.GDIFontObject, '{g|h_}', 1, @lbearing, @rBearing, @dummy, @tmAscent, @tmDescent); gdk_text_extents(CurrentFont^.GDIFontObject, TestString,
tmHeight := tmAscent + tmDescent + 2; //todo EXACT MEASUREMENT length(TestString), @lbearing, @rBearing, @dummy,
tmAveCharWidth := gdk_char_width(CurrentFont^.GDIFontObject, 'x'); // avarage is mostly measured by the x @tmAscent, @tmDescent);
tmMaxCharWidth := gdk_char_width(CurrentFont^.GDIFontObject, 'W'); // temp hack tmHeight := tmAscent + tmDescent + 2; //todo EXACT MEASUREMENT
AvrWidthStrLen := length(AvrWidthStr);
tmAveCharWidth := gdk_text_width(CurrentFont^.GDIFontObject,
AvrWidthStr,AvrWidthStrLen) div AvrWidthStrLen;
if tmAveCharWidth<2 then tmAveCharWidth:=2;
tmMaxCharWidth := gdk_char_width(CurrentFont^.GDIFontObject, 'W'); // temp hack
if tmMaxCharWidth<2 then tmMaxCharWidth:=2;
//writeln('TgtkObject.GetTextMetrics lbearing=',lbearing,' rBearing=',rBearing,
//' tmAscent=',tmAscent,' tmDescent=',tmDescent,' tmAveCharWidth=',tmAveCharWidth,
//' tmMaxCharWidth=',tmMaxCharWidth);
end;
end; end;
end;
Assert(False, Format('Trace:< TODO FINISH[TgtkObject.GetTextMetrics] DC: 0x%x', [DC])); Assert(False, Format('Trace:< TODO FINISH[TgtkObject.GetTextMetrics] DC: 0x%x', [DC]));
end; end;
@ -4632,6 +4720,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.74 2002/06/04 15:17:24 lazarus
MG: improved TFont for XLFD font names
Revision 1.73 2002/06/01 08:41:28 lazarus Revision 1.73 2002/06/01 08:41:28 lazarus
MG: DrawFramControl now uses gtk style, transparent STrechBlt MG: DrawFramControl now uses gtk style, transparent STrechBlt

4
lcl/interfaces/gtk/gtkwinapih.inc
View File

@ -47,6 +47,7 @@ function CreateCaret(Handle : HWND; Bitmap : hBitmap; width, Height : Integer) :
function CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; override; function CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; override;
function CreateCompatibleDC(DC: HDC): HDC; override; function CreateCompatibleDC(DC: HDC): HDC; override;
function CreateFontIndirect(const LogFont: TLogFont): HFONT; override; function CreateFontIndirect(const LogFont: TLogFont): HFONT; override;
function CreateFontIndirectEx(const LogFont: TLogFont; const LongFontName: string): HFONT; override;
function CreatePenIndirect(const LogPen: TLogPen): HPEN; override; function CreatePenIndirect(const LogPen: TLogPen): HPEN; override;
function CreatePixmapIndirect(const Data: Pointer; const TransColor: Longint): HBITMAP; override; function CreatePixmapIndirect(const Data: Pointer; const TransColor: Longint): HBITMAP; override;
function CreateRectRgn(X1,Y1,X2,Y2 : Integer): HRGN; override; function CreateRectRgn(X1,Y1,X2,Y2 : Integer): HRGN; override;
@ -153,6 +154,9 @@ Function WindowFromPoint(Point : TPoint) : HWND; override;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.31 2002/06/04 15:17:26 lazarus
MG: improved TFont for XLFD font names
Revision 1.30 2002/05/27 17:58:42 lazarus Revision 1.30 2002/05/27 17:58:42 lazarus
MG: added command line help MG: added command line help

4
lcl/lcllinux.pp
View File

@ -53,6 +53,7 @@ uses Classes, LCLType, VCLGlobals, GraphType;
function MakeLong(A,B : Word) : LongInt; function MakeLong(A,B : Word) : LongInt;
function MakeWord(A,B : Byte) : Word; function MakeWord(A,B : Byte) : Word;
implementation implementation
uses uses
@ -75,6 +76,9 @@ end.
{ {
$Log$ $Log$
Revision 1.19 2002/06/04 15:17:21 lazarus
MG: improved TFont for XLFD font names
Revision 1.18 2002/05/20 14:19:03 lazarus Revision 1.18 2002/05/20 14:19:03 lazarus
MG: activated the clientrect bugfixes MG: activated the clientrect bugfixes

79
lcl/lcltype.pp
View File

@ -375,7 +375,7 @@ PM_Remove = 1;
const const
{ 3D border styles } { 3D border styles }
BDR_RAISEDOUTER = 1; BDR_RAISEDOUTER = 1;
BDR_SUNKENOUTER = 2; BDR_SUNKENOUTER = 2;
BDR_RAISEDINNER = 4; BDR_RAISEDINNER = 4;
@ -768,37 +768,37 @@ BKMODE_LAST = 2;
CLIP_TT_ALWAYS = (2 shl 4); CLIP_TT_ALWAYS = (2 shl 4);
CLIP_EMBEDDED = (8 shl 4); CLIP_EMBEDDED = (8 shl 4);
DEFAULT_QUALITY = 0; DEFAULT_QUALITY = 0;
DRAFT_QUALITY = 1; DRAFT_QUALITY = 1;
PROOF_QUALITY = 2; PROOF_QUALITY = 2;
NONANTIALIASED_QUALITY = 3; NONANTIALIASED_QUALITY = 3;
ANTIALIASED_QUALITY = 4; ANTIALIASED_QUALITY = 4;
DEFAULT_PITCH = 0; DEFAULT_PITCH = 0;
FIXED_PITCH = 1; FIXED_PITCH = 1;
VARIABLE_PITCH = 2; VARIABLE_PITCH = 2;
MONO_FONT = 8; MONO_FONT = 8;
ANSI_CHARSET = 0; ANSI_CHARSET = 0;
DEFAULT_CHARSET = 1; DEFAULT_CHARSET = 1;
SYMBOL_CHARSET = 2; SYMBOL_CHARSET = 2;
SHIFTJIS_CHARSET = $80; MAC_CHARSET = 77;
HANGEUL_CHARSET = 129; SHIFTJIS_CHARSET = 128;
GB2312_CHARSET = 134; HANGEUL_CHARSET = 129;
JOHAB_CHARSET = 130;
GB2312_CHARSET = 134;
CHINESEBIG5_CHARSET = 136; CHINESEBIG5_CHARSET = 136;
OEM_CHARSET = 255; GREEK_CHARSET = 161;
JOHAB_CHARSET = 130; TURKISH_CHARSET = 162;
HEBREW_CHARSET = 177; VIETNAMESE_CHARSET = 163;
ARABIC_CHARSET = 178; HEBREW_CHARSET = 177;
GREEK_CHARSET = 161; ARABIC_CHARSET = 178;
TURKISH_CHARSET = 162; BALTIC_CHARSET = 186;
VIETNAMESE_CHARSET = 163; RUSSIAN_CHARSET = 204;
THAI_CHARSET = 222; THAI_CHARSET = 222;
EASTEUROPE_CHARSET = 238; EASTEUROPE_CHARSET = 238;
RUSSIAN_CHARSET = 204; OEM_CHARSET = 255;
MAC_CHARSET = 77;
BALTIC_CHARSET = 186;
//----------- //-----------
// Font Sets // Font Sets
@ -833,21 +833,21 @@ BKMODE_LAST = 2;
//-------------- //--------------
// Font Weights // Font Weights
//-------------- //--------------
FW_DONTCARE = 0; FW_DONTCARE = 0;
FW_THIN = 100; FW_THIN = 100;
FW_EXTRALIGHT = 200; FW_EXTRALIGHT = 200;
FW_LIGHT = 300; FW_LIGHT = 300;
FW_NORMAL = 400; FW_NORMAL = 400;
FW_MEDIUM = 500; FW_MEDIUM = 500;
FW_SEMIBOLD = 600; FW_SEMIBOLD = 600;
FW_BOLD = 700; FW_BOLD = 700;
FW_EXTRABOLD = 800; FW_EXTRABOLD = 800;
FW_HEAVY = 900; FW_HEAVY = 900;
FW_ULTRALIGHT = FW_EXTRALIGHT; FW_ULTRALIGHT = FW_EXTRALIGHT;
FW_REGULAR = FW_NORMAL; FW_REGULAR = FW_NORMAL;
FW_DEMIBOLD = FW_SEMIBOLD; FW_DEMIBOLD = FW_SEMIBOLD;
FW_ULTRABOLD = FW_EXTRABOLD; FW_ULTRABOLD = FW_EXTRABOLD;
FW_BLACK = FW_HEAVY; FW_BLACK = FW_HEAVY;
//============================================== //==============================================
// Brush constants // Brush constants
@ -1406,6 +1406,9 @@ end.
{ {
$Log$ $Log$
Revision 1.7 2002/06/04 15:17:22 lazarus
MG: improved TFont for XLFD font names
Revision 1.6 2002/05/28 19:39:45 lazarus Revision 1.6 2002/05/28 19:39:45 lazarus
MG: added gtk rc file support and started stule dependent syscolors MG: added gtk rc file support and started stule dependent syscolors