(*
/*

CLASS {AL4_font|_Delphi_KOL}, NATIVE, UNTESTED :
IMPORT: {Font} ;

NATIVE: "uses AL4_font, Windows;" .

NATIVE: "///COPY AL4_font.pas" .

*/
*)
unit AL4_font;
{$I EXTERNAL_DEFINES.inc}
{$I KOLDEF.inc}

interface

uses {$IFDEF KOL} KOL 
     {$ELSE} Classes, Forms, Controls, Menus, 
             StdCtrls, ExtCtrls, ComCtrls, Dialogs, Graphics
     {$ENDIF},
// use AL4 to access system functions (AL4.pas inserted by the compiler into
// a project folder)
     AL4,
// use All_classes from a project folder (generated for a certain project)
     All_classes, AL4_form, unitC_Control {to access NoneObj_C_Control},
     Windows, Messages;

//{$WARN UNIT_DEPRECATED OFF}
//{$WARN SYMBOL_PLATFORM OFF}
//{$IFDEF Delphi7}
//{$WARN UNSAFE_TYPE OFF}
//{$WARN UNSAFE_CAST OFF}
//{$WARN UNSAFE_CODE OFF}
//{$ENDIF}



// font Functions
//? {Canvas}
function Do_Create_font(X_F: Ref_obj; const X_Face: String;
         X_Size: Double): Integer;

procedure Do_Destroy_font(X_F: Integer);
function Do_Change_font_face_size(X_F: Integer; const X_Face: String;
          X_Size: Double): Double;
procedure Do_Change_font_style(X_F: Integer; X_Index: Integer;
          X_Style: Boolean);
procedure Do_Change_font_charset(X_F: Integer; X_Charset: Integer);
//.

function Get_font_style(f: C_Font): TFontStyle;

implementation

//---------------------------------------------------------------------- F O N T

(*
/*
// Create TFontEx object, return descriptor
//---------------------------------------
FUN Create_font({Font} F|ont_object, STR Face|_font,
    REAL Size|_font) ==> INT, NATIVE :
   @"//? {Canvas}"
    "    RESULT := Do_Create_font(X_F, X_Face, X_Size);"
    "//." .
*/
*)
function Do_Create_font(X_F: Ref_obj; const X_Face: String;
         X_Size: Double): Integer;
var Font: PGraphicTool;
begin
    Font := NewFont;
    if X_Face <> '' then Font.FontName := X_Face;
    Font.FontHeight := Points(X_Size);
    Font.Tag := Integer(X_F);
    Result := Integer(Font);
end;

(*
/*
// Destroy TFontEx object
//----------------------
FUN Destroy_font(INT F|ont_handle), NATIVE :
   @"//? {Canvas}"
    "     Do_Destroy_font(X_F);"
    "//." .
*/
*)
procedure Do_Destroy_font(X_F: Integer);
//?{Font}
var Font: PGraphicTool;
//.
begin
//?{Font}
    Font := PGraphicTool(X_F);
    TRY
    Font.Free;
    EXCEPT
    END;
//.
end;

(*
/*
// Change font face and size
//--------------------------
FUN Change_font_face_size(INT F|ont_handle, STR Face|_font,
    REAL Size|_font) ==> REAL, NATIVE :
   @"//? {Canvas}"
    "    RESULT := Do_Change_font_face_size(X_F, X_Face, X_Size);"
    "//." .
*/
*)
function Do_Change_font_face_size(X_F: Integer; const X_Face: String;
          X_Size: Double): Double;
//?{Font}
var Font: PGraphicTool;
	R: Ref_obj;
	C_F: C_Font;
	C: PCanvas;
	res: Integer;
	dc0: HDC;
//.
begin
//?{Font}
    Font := PGraphicTool(X_F);
    Font.FontName := X_Face;
             
	R := Ref_obj(Font.Tag);
	C_F := C_Font(R.Obj);
	if C_F.F_Canvas_.Obj.Is_NONE_object then	
		Font.FontHeight := Points(X_Size)
	else
	begin
		C := PCanvas(C_F.F_Handle);
		if C.Handle <> 0 then
			res := GetDeviceCaps(C.Handle, LOGPIXELSX)
		else
		begin
			dc0 := GetDC(0);
			res := GetDeviceCaps(dc0, LOGPIXELSX);
			ReleaseDC(0, dc0);
		end;
		Font.FontHeight := Round(X_Size / 72.0 * res);
	end;
    RESULT := Pixels(Font.FontHeight);
//.
end;

(*
/*
// Change font style
//------------------

FUN Change_font_style(INT F|ont_handle, STR Styles|_BIUS)
    :
    Do_change_font_style(F, 0, "B" IN Styles)
    Do_change_font_style(F, 1, "I" IN Styles)
    Do_change_font_style(F, 2, "U" IN Styles)
    Do_change_font_style(F, 3, "S" IN Styles) .

FUN Do_change_font_style(INT F|ont_handle, INT Index|_style,
    BOOL Style|_value), NATIVE :
    @"//? {Canvas}"
    "     Do_Change_font_style(X_F, X_Index, X_Style);"
    "//." .
*/
*)
procedure Do_Change_font_style(X_F: Integer; X_Index: Integer;
          X_Style: Boolean);
//?{Font}
var Font: PGraphicTool;
    FS: TFontStyles;
//.
begin
//?{Font}
    Font := PGraphicTool(X_F);
    FS := TFontStyles(X_Index);
    if  X_Style then
        Font.FontStyle := Font.FontStyle + [FS]
    else Font.FontStyle := Font.FontStyle - [FS];
//.
end;

(*
/*
// Change font charset
//--------------------
FUN Change_font_charset(INT F|ont_handle,
    INT Charset|_font), NATIVE :
   @"//? {Canvas}"
    "     Do_Change_font_charset(X_F, X_Charset);"
    "//." .
*/
*)
procedure Do_Change_font_charset(X_F: Integer; X_Charset: Integer);
//?{Font}
var Font: PGraphicTool;
//.
begin
//?{Font}
    Font := PGraphicTool(X_F);
    Font.FontCharset := X_Charset;
//.
end;
//.

function Get_font_style(f: C_Font): TFontStyle;
begin
    Result := [];
    if  f.f_Bold then Result := Result + [fsBold];
    if  f.f_Italic then Result := Result + [fsItalic];
    if  f.f_Underline then Result := Result + [fsUnderline];
    if  f.f_Strikeout then Result := Result + [fsStrikeOut];
end;

end.
(*
/*
END
*/
*)



