pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

implemented GetTextAttribs for carbon

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@823 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
skalogryz
2009-06-06 08:21:08 +00:00
parent d48379d957
commit 7ae85c5538
1 changed files with 125 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

140
components/richmemo/carbon/carbonrichmemo.pas
View File

@ -1,4 +1,4 @@
unit carbonrichmemo;
unit CarbonRichMemo;
{$mode objfpc}{$H+}
@ -22,6 +22,11 @@ type
TCarbonRichEdit = class(TCarbonMemo)
protected
function GetCreationOptions: TXNFrameOptions; override;
public
function GetContinuousTypeAttributes(var oContinuousFlags: TXNContinuousFlags;
iCount: ItemCount; var ioTypeAttributes: array of TXNTypeAttributes): Boolean;
function SetTypeAttributes(iCount: ItemCount; const iTypeAttributes: array of TXNTypeAttributes;
StartOffset, EndOffset: Integer): Boolean;
end;
{ TCarbonWSCustomRichMemo }
@ -40,6 +45,62 @@ implementation
const
TXNAttributesMax = 10;
function GetATSUFontName(AStyle: ATSUStyle): String;
var
fontid: ATSUFontID;
begin
ATSUGetAttribute(AStyle, kATSUFontTag, sizeof(ATSUFontID), @fontid, nil);
Result := CarbonFontIDToFontName(fontid);
end;
function GetATSUFontSize(ASTyle: ATSUStyle): Integer;
var
sz : fixed;
begin
ATSUGetAttribute(AStyle, kATSUSizeTag, sizeof(fixed), @sz, nil);
Result := Fix2Long(sz);
end;
procedure GetATSUFontRGBAColor(AStyle: ATSUStyle; var r,g,b,a: Byte);
var
rgba : ATSURGBAlphaColor;
begin
ATSUGetAttribute(AStyle, kATSURGBAlphaColorTag, sizeof(Boolean), @rgba, nil);
r := Round(rgba.red*255);
g := Round(rgba.green*255);
b := Round(rgba.blue*255);
a := Round(rgba.alpha*255);
end;
function GetATSUFontColor(AStyle: ATSUStyle): TColor;
var
r,g,b,a: Byte;
begin
GetATSUFontRGBAColor(AStyle, r,g,b,a);
Result := (b shl 16) or (g shl 8) or r;
end;
function GetATSUFontStyles(AStyle: ATSUStyle): TFontStyles;
var
b : Boolean;
begin
b:=false;
Result := [];
ATSUGetAttribute(AStyle, kATSUQDBoldfaceTag, sizeof(Boolean), @b, nil);
if b then Include(Result, fsBold);
ATSUGetAttribute(AStyle, kATSUQDItalicTag, sizeof(Boolean), @b, nil);
if b then Include(Result, fsItalic);
ATSUGetAttribute(AStyle, kATSUQDUnderlineTag, sizeof(Boolean), @b, nil);
if b then Include(Result, fsUnderline);
ATSUGetAttribute(AStyle, kATSUStyleStrikeThroughTag , sizeof(Boolean), @b, nil);
if b then Include(Result, fsStrikeOut);
end;
function IsValidControlHandle(AWinControl: TWinControl): Boolean;
begin
Result := Assigned(AWinControl) and (AWinControl.Handle<>0);
end;
procedure AttrSetFontName(const FontName: String; var Attr: TXNTypeAttributes);
begin
Attr.tag := kATSUFontTag;
@ -65,12 +126,14 @@ procedure AttrSetStyle(FontStyle: TFontStyles; var Attr: TXNTypeAttributes);
begin
Attr.tag := kTXNQDFontStyleAttribute;
Attr.size := kTXNQDFontStyleAttributeSize;
Attr.data.dataValue := normal;
Attr.data.dataValue := FontStyleToQDStyle(FontStyle)
end;
if fsBold in FontStyle then Attr.data.dataValue := Attr.data.dataValue or bold;
if fsItalic in FontStyle then Attr.data.dataValue := Attr.data.dataValue or italic;
if fsUnderline in FontStyle then Attr.data.dataValue := Attr.data.dataValue or underline;
// if fsStrikeOut in FontStyle then ... can be implemented only by using ATSU
procedure AttrSetATSUStyle(AStyle: ATSUStyle; var Attr: TXNTypeAttributes);
begin
Attr.tag := kTXNATSUIStyle;
Attr.size := kTXNATSUIStyleSize;
Attr.data.dataPtr := astyle;
end;
procedure ParamsToTXNAttribs(ParamsMask: TTextStyleMask; const Params: TFontParams;
@ -111,26 +174,57 @@ end;
class function TCarbonWSCustomRichMemo.GetTextAttributes(const AWinControl: TWinControl;
TextStart: Integer; var Params: TFontParams): Boolean;
var
memo : TCarbonRichEdit;
attr : array [0..1] of TXNTypeAttributes;
sstart : Integer;
slen : Integer;
flags : TXNContinuousFlags;
astyle : ATSUStyle;
begin
Result:=false;
Result := IsValidControlHandle(AWinControl);
if not Result then Exit;
memo := TCarbonRichEdit(AWinControl.Handle);
memo.GetSelStart(sstart);
memo.GetSelLength(slen);
memo.SetSelStart(TextStart);
memo.SetSelLength(1);
ATSUCreateStyle(astyle);
AttrSetATSUStyle(astyle, attr[0]);
AttrSetStyle([], attr[1]);
Result := memo.GetContinuousTypeAttributes(flags, 2, attr);
Params.Name := GetATSUFontName(astyle);
Params.Color := GetATSUFontColor(astyle);
Params.Style := GetATSUFontStyles(astyle) + QDStyleToFontStyle(attr[1].data.dataValue);
Params.Size := GetATSUFontSize(astyle);
ATSUDisposeStyle(astyle);
memo.SetSelLength(sstart);
memo.SetSelLength(slen);
end;
class procedure TCarbonWSCustomRichMemo.SetTextAttributes(const AWinControl: TWinControl;
TextStart, TextLen: Integer;
Mask: TTextStyleMask; const Params: TFontParams);
var
memo : TCarbonMemo;
attr : array [0..TXNAttributesMax-1] of TXNTypeAttributes;
attrcount : Integer;
memo : TCarbonRichEdit;
Attr : array [0..TXNAttributesMax-1] of TXNTypeAttributes;
Count : Integer;
maccolor : RGBColor;
begin
if not Assigned(AWinControl) or (AWinControl.Handle = 0) then Exit;
memo := TCarbonMemo(AWinControl.Handle);
if not IsValidControlHandle(AWinControl) then Exit;
memo := TCarbonRichEdit(AWinControl.Handle);
ParamsToTXNAttribs(Mask, Params, attr, attrcount, maccolor);
ParamsToTXNAttribs(Mask, Params, attr, Count, maccolor);
TXNSetTypeAttributes(HITextViewGetTXNObject(ControlRef(memo.Widget)), attrcount, @Attr[0],
TextStart, TextStart+TextLen);
memo.SetTypeAttributes(Count, Attr, TextStart, TextStart+TextLen);
end;
class procedure TCarbonWSCustomRichMemo.SetHideSelection(const AWinControl: TWinControl;
@ -146,5 +240,21 @@ begin
Result := kOutputTextInUnicodeEncodingMask;
end;
function TCarbonRichEdit.GetContinuousTypeAttributes(
var oContinuousFlags: TXNContinuousFlags; iCount: ItemCount;
var ioTypeAttributes: array of TXNTypeAttributes): Boolean;
begin
Result := TXNGetContinuousTypeAttributes(HITextViewGetTXNObject(Widget),
oContinuousFlags, iCount, @ioTypeAttributes[0]) = noErr;
end;
function TCarbonRichEdit.SetTypeAttributes(iCount: ItemCount;
const iTypeAttributes: array of TXNTypeAttributes; StartOffset,
EndOffset: Integer): Boolean;
begin
Result := TXNSetTypeAttributes(HITextViewGetTXNObject(Widget), iCount,
@iTypeAttributes[0], StartOffset, EndOffset) = noErr;
end;
end.