git-svn-id: https://svn.code.sf.net/p/kolmck/code@9 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
424
Addons/KOLFontEditor.pas
Normal file
424
Addons/KOLFontEditor.pas
Normal file
@ -0,0 +1,424 @@
|
||||
unit KOLFontEditor;
|
||||
{
|
||||
==================================================================
|
||||
|
||||
TKOLFont Property Editor
|
||||
for MCK
|
||||
|
||||
-----------------------------------------------
|
||||
Version: 1.0
|
||||
Date: 16-sep-2003
|
||||
Author: (C) Alexander Pravdin (aka SPeller)
|
||||
e-mail: speller@mail.primorye.ru
|
||||
www: http://kol.mastak.ru
|
||||
http://bonanzas.rinet.ru
|
||||
|
||||
Thanks to:
|
||||
Dmitry Zharov (aka Gandalf):
|
||||
Start point of this component (MHFontDialog).
|
||||
Delphi 5 and Delphi 7 support.
|
||||
|
||||
Tested Delphi versions: 5, 6, 7.
|
||||
|
||||
==================================================================}
|
||||
|
||||
interface
|
||||
|
||||
{$I KOLDEF.INC}
|
||||
|
||||
uses KOL, Windows, Messages, Graphics, Forms, CommDlg, Mirror,
|
||||
{$IFDEF _D6orHigher}
|
||||
DesignEditors, DesignIntf;
|
||||
{$ELSE}
|
||||
DsgnIntf;
|
||||
{$ENDIF}
|
||||
|
||||
type
|
||||
|
||||
TKOLFontProperty = class(TClassProperty)
|
||||
private
|
||||
DlgWnd,
|
||||
hWndOwner,
|
||||
LabelWnd,
|
||||
PickWnd,
|
||||
FontLWnd,
|
||||
EditWnd,
|
||||
CBWnd: HWND;
|
||||
ColorDlg: PColorDialog;
|
||||
Top, Left, Height, Width,
|
||||
OldPickWndProc,
|
||||
OldEditWndProc: Integer;
|
||||
Colors: PList;
|
||||
Font: TFont;
|
||||
Color: Integer;
|
||||
function DlgExecute: Boolean;
|
||||
public
|
||||
function GetAttributes: TPropertyAttributes; override;
|
||||
procedure Edit; override;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
ID_DLGOBJ = 'ID_DLGOBJ'#0;
|
||||
DLG_LBLID = 11200;
|
||||
DLG_PICKID = 11201;
|
||||
DLG_EDITID = 11202;
|
||||
DLG_COLORCB = 1139;
|
||||
DLG_EFFECTSGROUP = 1072;
|
||||
|
||||
CN_APPLYCOLOR = 501;
|
||||
|
||||
function PickWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
|
||||
var
|
||||
_Self : TKOLFontProperty;
|
||||
R : TRect;
|
||||
hBr, DC : THandle;
|
||||
begin
|
||||
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
|
||||
with _Self do
|
||||
begin
|
||||
case Msg of
|
||||
WM_PAINT:
|
||||
begin
|
||||
GetClientRect(Wnd, R);
|
||||
CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam);
|
||||
hBr := CreateSolidBrush(Color);
|
||||
DC := GetDC(Wnd);
|
||||
FillRect(DC, R, hBr);
|
||||
ReleaseDC(Wnd, DC);
|
||||
DeleteObject(hBr);
|
||||
Result := 0;
|
||||
Exit;
|
||||
end;
|
||||
end; // case
|
||||
Result := CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam);
|
||||
end; // with
|
||||
end;
|
||||
|
||||
function EditWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
|
||||
var
|
||||
_Self : TKOLFontProperty;
|
||||
begin
|
||||
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
|
||||
with _Self do
|
||||
begin
|
||||
Result := CallWindowProc(Pointer(OldEditWndProc), Wnd, Msg, wParam, lParam);
|
||||
end; // with
|
||||
end;
|
||||
|
||||
function FontDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall;
|
||||
var
|
||||
_Self : TKOLFontProperty;
|
||||
R, R2, SR : TRect;
|
||||
I, tmID, CBCurSel, CBCount: Integer;
|
||||
PCF : PChooseFontA;
|
||||
tmWnd, ChildWnd, hFont: THandle;
|
||||
st : string;
|
||||
FR : Boolean;
|
||||
begin
|
||||
Result := 0;
|
||||
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
|
||||
if (_Self = nil) and (Msg = WM_INITDIALOG) then
|
||||
begin
|
||||
PCF := Pointer(lParam);
|
||||
SetProp(Wnd, ID_DLGOBJ, Cardinal(PCF.lCustData));
|
||||
_Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
|
||||
end;
|
||||
|
||||
with _Self do
|
||||
begin
|
||||
case Msg of
|
||||
WM_INITDIALOG:
|
||||
begin
|
||||
DlgWnd := Wnd;
|
||||
GetWindowRect(Wnd, R);
|
||||
SR := MakeRect(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN));
|
||||
Width := R.Right - R.Left;
|
||||
Height := R.Bottom - R.Top + 0;
|
||||
Left := (SR.Left + SR.Right - Width) div 2;
|
||||
Top := (SR.Top + SR.Bottom - Height) div 2;
|
||||
SetWindowPos(Wnd, 0, Left, Top, Width, Height, SWP_NOZORDER);
|
||||
|
||||
ChildWnd := 0;
|
||||
repeat
|
||||
ChildWnd := FindWindowEx(Wnd, ChildWnd, 'COMBOBOX', nil);
|
||||
tmID := GetWindowLong(ChildWnd, GWL_ID);
|
||||
until (tmID = DLG_COLORCB) or (ChildWnd = 0);
|
||||
if ChildWnd <> 0 then
|
||||
begin
|
||||
CBWnd := ChildWnd;
|
||||
GetWindowRect(CBWnd, R);
|
||||
R.Right := R.Right + 5;
|
||||
SetWindowPos(CBWnd, 0, 0, 0, R.Right - R.Left, R.Bottom - R.Top, SWP_NOZORDER or SWP_NOMOVE);
|
||||
end else
|
||||
Exit;
|
||||
|
||||
ChildWnd := 0;
|
||||
repeat
|
||||
ChildWnd := FindWindowEx(Wnd, ChildWnd, 'BUTTON', nil);
|
||||
tmID := GetWindowLong(ChildWnd, GWL_ID);
|
||||
until (tmID = DLG_EFFECTSGROUP) or (ChildWnd = 0);
|
||||
if ChildWnd <> 0 then
|
||||
begin
|
||||
tmWnd := ChildWnd;
|
||||
GetWindowRect(tmWnd, R);
|
||||
ScreenToClient(Wnd, R.TopLeft);
|
||||
ScreenToClient(Wnd, R.BottomRight);
|
||||
R.Bottom := R.Bottom + 20;
|
||||
SetWindowPos(tmWnd, HWND_BOTTOM, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, 0);
|
||||
end else
|
||||
Exit;
|
||||
|
||||
ChildWnd := 0;
|
||||
repeat
|
||||
ChildWnd := FindWindowEx(Wnd, ChildWnd, 'STATIC', nil);
|
||||
tmID := GetWindowLong(ChildWnd, GWL_ID);
|
||||
until (tmID = 1093) or (ChildWnd = 0);
|
||||
if ChildWnd <> 0 then
|
||||
begin
|
||||
FontLWnd := ChildWnd;
|
||||
GetWindowRect(FontLWnd, R2);
|
||||
R2 := MakeRect(7, 172, 219, 20);
|
||||
R2.Top := R2.Top + 25;
|
||||
R2.Bottom := R2.Bottom + 20;
|
||||
SetWindowPos(FontLWnd, 0, R2.Left, R2.Top, R2.Right - R2.Left, R2.Bottom - R2.Top, SWP_NOZORDER);
|
||||
end;
|
||||
|
||||
LabelWnd := CreateWindow('STATIC', 'Exactly:',
|
||||
SS_LEFT or WS_VISIBLE or WS_CHILD,
|
||||
R.Left + 10, R.Bottom - 26, 40, 15,
|
||||
Wnd, 0, hInstance, nil);
|
||||
SetWindowLong(LabelWnd, GWL_ID, DLG_LBLID);
|
||||
SetProp(LabelWnd, ID_DLGOBJ, Cardinal(_Self));
|
||||
hFont := SendMessage(Wnd, WM_GETFONT, 0, 0);
|
||||
SendMessage(LabelWnd, WM_SETFONT, hFont, 0);
|
||||
|
||||
if WinVer >= wvXP then
|
||||
begin
|
||||
I := 0;
|
||||
tmID := WS_BORDER;
|
||||
end else
|
||||
begin
|
||||
I := WS_EX_CLIENTEDGE;
|
||||
tmID := 0;
|
||||
end;
|
||||
PickWnd := CreateWindowEx(I,
|
||||
'STATIC', nil,
|
||||
WS_VISIBLE or WS_CHILD or SS_NOTIFY or tmID,
|
||||
R.Left + 116, R.Bottom - 30, 21, 21,
|
||||
Wnd, 0, hInstance, nil);
|
||||
SetProp(PickWnd, ID_DLGOBJ, Cardinal(_Self));
|
||||
SetWindowLong(PickWnd, GWL_ID, DLG_PICKID);
|
||||
OldPickWndProc := SetWindowLong(PickWnd, GWL_WNDPROC, Integer(@PickWndProc));
|
||||
|
||||
EditWnd := CreateWindowEx(WS_EX_CLIENTEDGE,
|
||||
'EDIT', nil,
|
||||
WS_VISIBLE or WS_CHILD or ES_UPPERCASE or ES_AUTOHSCROLL,
|
||||
R.Left + 60, R.Bottom - 30, 55, 21,
|
||||
Wnd, 0, hInstance, nil);
|
||||
SetWindowLong(EditWnd, GWL_ID, DLG_EDITID);
|
||||
SetProp(EditWnd, ID_DLGOBJ, Cardinal(_Self));
|
||||
SendMessage(EditWnd, WM_SETFONT, hFont, 0);
|
||||
SendMessage(EditWnd, EM_SETLIMITTEXT, 6, 0);
|
||||
OldEditWndProc := SetWindowLong(EditWnd, GWL_WNDPROC, Integer(@EditWndProc));
|
||||
|
||||
ColorDlg.OwnerWindow := Wnd;
|
||||
|
||||
CBCount := SendMessage(CBWnd, CB_GETCOUNT, 0, 0);
|
||||
for I := 0 to CBCount - 1 do
|
||||
begin
|
||||
Colors.Add(Pointer(SendMessage(CBWnd, CB_GETITEMDATA, I, 0)));
|
||||
end;
|
||||
CBCurSel := Colors.IndexOf(Pointer(Color));
|
||||
if CBCurSel < 0 then
|
||||
begin
|
||||
SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6))));
|
||||
Colors.Add(Pointer(Color));
|
||||
CBCurSel := Colors.Count - 1;
|
||||
SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color);
|
||||
end;
|
||||
SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0);
|
||||
TSmallPoint(I).x := DLG_COLORCB;
|
||||
TSmallPoint(I).y := CBN_SELCHANGE;
|
||||
SendMessage(Wnd, WM_COMMAND, I, CBWnd);
|
||||
|
||||
end;
|
||||
|
||||
WM_COMMAND:
|
||||
begin
|
||||
case TSmallPoint(wParam).X of
|
||||
DLG_PICKID:
|
||||
begin
|
||||
case TSmallPoint(wParam).Y of
|
||||
STN_CLICKED:
|
||||
begin
|
||||
if GetWindowLong(PickWnd, GWL_USERDATA) = CN_APPLYCOLOR then
|
||||
FR := True
|
||||
else
|
||||
begin
|
||||
ColorDlg.Color := Color;
|
||||
FR := ColorDlg.Execute;
|
||||
if FR then Color := ColorDlg.Color;
|
||||
end;
|
||||
if FR then
|
||||
begin
|
||||
//-----
|
||||
CBCurSel := Colors.IndexOf(Pointer(Color));
|
||||
if CBCurSel < 0 then
|
||||
begin
|
||||
SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6))));
|
||||
Colors.Add(Pointer(Color));
|
||||
CBCurSel := Colors.Count - 1;
|
||||
SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color);
|
||||
end;
|
||||
SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0);
|
||||
TSmallPoint(I).Y := CBN_SELCHANGE;
|
||||
TSmallPoint(I).X := DLG_COLORCB;
|
||||
SendMessage(Wnd, WM_COMMAND, I, CBWnd);
|
||||
//-----
|
||||
end;
|
||||
end; // STN_CLICKED
|
||||
end; // case
|
||||
end; // DLG_PICKID
|
||||
|
||||
DLG_COLORCB:
|
||||
begin
|
||||
if TSmallPoint(wParam).Y = CBN_SELCHANGE then
|
||||
begin
|
||||
CBCurSel := SendMessage(CBWnd, CB_GETCURSEL, 0, 0);
|
||||
if CBCurSel >= 0 then
|
||||
begin
|
||||
Color := SendMessage(CBWnd, CB_GETITEMDATA, CBCurSel, 0);
|
||||
SetWindowText(EditWnd, PChar(Int2Hex(Color, 6)));
|
||||
SendMessage(PickWnd, WM_PAINT, 0, 0);
|
||||
end;
|
||||
end;
|
||||
end; // DLG_COLORCB
|
||||
|
||||
DLG_EDITID:
|
||||
begin
|
||||
case TSmallPoint(wParam).Y of
|
||||
EN_CHANGE:
|
||||
begin
|
||||
SetLength(st, 20);
|
||||
GetWindowText(EditWnd, @st[1], 18);
|
||||
Color := Hex2Int(st);
|
||||
SendMessage(PickWnd, WM_PAINT, 0, 0);
|
||||
end;
|
||||
end;
|
||||
end; // DLG_EDITID
|
||||
|
||||
end; // case TSmallPoint( wParam ).X
|
||||
end; // WM_COMMAND
|
||||
|
||||
end; // case
|
||||
end; // with
|
||||
end;
|
||||
|
||||
function TKOLFontProperty.DlgExecute: Boolean;
|
||||
var
|
||||
TMPCF : tagChooseFont;
|
||||
TMPLogFont : tagLogFontA;
|
||||
begin
|
||||
FillChar(TMPCF, SizeOf(TMPCF), 0);
|
||||
GetObject(Font.Handle, SizeOf(tagLOGFONT), @TMPLogFont);
|
||||
|
||||
TMPCF.lStructSize := Sizeof(TMPCF);
|
||||
TMPCF.hWndOwner := hWndOwner;
|
||||
TMPCF.Flags := CF_EFFECTS or CF_BOTH or CF_ENABLEHOOK or CF_INITTOLOGFONTSTRUCT;
|
||||
TMPCF.lpfnHook := FontDialogHook;
|
||||
TMPCF.lpLogFont := @TMPLogFont;
|
||||
TMPCF.rgbColors := Color2RGB(Font.Color);
|
||||
TMPCF.lCustData := Integer(Self);
|
||||
Color := TMPCF.rgbColors;
|
||||
|
||||
Result := ChooseFont(TMPCF);
|
||||
|
||||
if Result then
|
||||
begin
|
||||
DeleteObject(Font.Handle);
|
||||
Font.Handle := CreateFontIndirect(TMPLogFont);
|
||||
Font.Color := Color;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TKOLFontProperty.GetAttributes: TPropertyAttributes;
|
||||
begin
|
||||
Result := inherited GetAttributes + [paDialog, paReadOnly];
|
||||
end;
|
||||
|
||||
procedure TKOLFontProperty.Edit;
|
||||
const
|
||||
Pitch2API : array[TFontPitch] of Byte = (DEFAULT_PITCH, VARIABLE_PITCH, FIXED_PITCH);
|
||||
var
|
||||
LF : tagLOGFONT;
|
||||
F : TKOLFont;
|
||||
FS1 : TFontStyles;
|
||||
begin
|
||||
//----------------
|
||||
hWndOwner := Application.Handle;
|
||||
Font := TFont.Create;
|
||||
Colors := NewList;
|
||||
ColorDlg := NewColorDialog(ccoFullOpen);
|
||||
//-----------------
|
||||
F := TKOLFont(GetOrdValue);
|
||||
|
||||
FillChar(LF, SizeOf(tagLOGFONT), 0);
|
||||
LF.lfHeight := F.FontHeight;
|
||||
LF.lfWidth := F.FontWidth;
|
||||
LF.lfOrientation := F.FontOrientation;
|
||||
if fsBold in F.FontStyle then LF.lfWeight := 700;
|
||||
LF.lfItalic := Byte(fsItalic in F.FontStyle);
|
||||
LF.lfUnderline := Byte(fsUnderline in F.FontStyle);
|
||||
LF.lfStrikeOut := Byte(fsStrikeOut in F.FontStyle);
|
||||
LF.lfCharSet := F.FontCharset;
|
||||
LF.lfPitchAndFamily := Pitch2API[F.FontPitch];
|
||||
Move(F.FontName[1], LF.lfFaceName, Length(F.FontName));
|
||||
Font.Color := F.Color;
|
||||
|
||||
Font.Handle := CreateFontIndirect(LF);
|
||||
|
||||
if DlgExecute then
|
||||
begin
|
||||
FillChar(LF, SizeOf(tagLOGFONT), 0);
|
||||
GetObject(Font.Handle, SizeOf(tagLOGFONT), @LF);
|
||||
F.FontHeight := LF.lfHeight;
|
||||
F.FontWidth := LF.lfWidth;
|
||||
F.FontOrientation := LF.lfOrientation;
|
||||
|
||||
FS1 := [];
|
||||
if Boolean(LF.lfItalic) then Include(FS1, fsItalic);
|
||||
if Boolean(LF.lfUnderline) then Include(FS1, fsUnderline);
|
||||
if Boolean(LF.lfStrikeOut) then Include(FS1, fsStrikeout);
|
||||
if LF.lfWeight > FW_NORMAL then Include(FS1, fsBold);
|
||||
F.FontStyle := FS1;
|
||||
|
||||
F.FontCharset := LF.lfCharSet;
|
||||
case LF.lfPitchAndFamily of
|
||||
DEFAULT_PITCH: F.FontPitch := fpDefault;
|
||||
FIXED_PITCH: F.FontPitch := fpFixed;
|
||||
VARIABLE_PITCH: F.FontPitch := fpVariable;
|
||||
end;
|
||||
F.FontName := LF.lfFaceName;
|
||||
F.Color := Font.Color;
|
||||
|
||||
SetOrdValue(Integer(F));
|
||||
end;
|
||||
|
||||
//-----------------
|
||||
ColorDlg.Free;
|
||||
Colors.Free;
|
||||
Font.Free;
|
||||
//-----------------
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterPropertyEditor(TypeInfo(TKOLFont), nil, '', TKOLFontProperty);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Reference in New Issue
Block a user