From 97024d8fc5127e2b35ada12ac293e2e7710db71f Mon Sep 17 00:00:00 2001 From: tombo Date: Thu, 6 Sep 2007 12:29:06 +0000 Subject: [PATCH] Carbon intf: partially implemented TFontDialog git-svn-id: trunk@11949 - --- lcl/interfaces/carbon/carbongdiobjects.pp | 41 +++-- lcl/interfaces/carbon/carbonlclintf.inc | 8 +- lcl/interfaces/carbon/carbonproc.pp | 31 ++++ lcl/interfaces/carbon/carbonwinapi.inc | 15 +- lcl/interfaces/carbon/carbonwsdialogs.pp | 189 +++++++++++++++++++++- 5 files changed, 253 insertions(+), 31 deletions(-) diff --git a/lcl/interfaces/carbon/carbongdiobjects.pp b/lcl/interfaces/carbon/carbongdiobjects.pp index c7bc133991..60c2d768f7 100644 --- a/lcl/interfaces/carbon/carbongdiobjects.pp +++ b/lcl/interfaces/carbon/carbongdiobjects.pp @@ -83,7 +83,8 @@ type FLineRotation: Fixed; public constructor Create(AGlobal: Boolean); // default system font - constructor Create(ALogFont: TLogFont; AFaceName: String); + constructor Create(ALogFont: TLogFont; const AFaceName: String); + function CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle; destructor Destroy; override; public property LineRotation: Fixed read FLineRotation; @@ -697,7 +698,23 @@ end; Creates Carbon font with the specified name and characteristics ------------------------------------------------------------------------------} -constructor TCarbonFont.Create(ALogFont: TLogFont; AFaceName: String); +constructor TCarbonFont.Create(ALogFont: TLogFont; const AFaceName: String); +begin + inherited Create(False); + + FStyle := CreateStyle(ALogFont, AFaceName); + + // applied when creating text layout + FLineRotation := (ALogFont.lfEscapement shl 16) div 10; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonFont.CreateStyle + Params: ALogFont - Font characteristics + AFaceName - Name of the font + Returns: ATSUStyle for the specified font name and characteristics + ------------------------------------------------------------------------------} +function TCarbonFont.CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle; var Attr: ATSUAttributeTag; M: ATSUTextMeasurement; @@ -707,10 +724,11 @@ var ID: ATSUFontID; const SSetAttrs = 'ATSUSetAttributes'; + SName = 'CreateStyle'; begin inherited Create(False); - - OSError(ATSUCreateStyle(FStyle), Self, SCreate, SCreateStyle); + + OSError(ATSUCreateStyle(Result), Self, SName, SCreateStyle); ID := FindCarbonFontID(AFaceName); @@ -719,7 +737,7 @@ begin Attr := kATSUFontTag; A := @ID; S := SizeOf(ID); - OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, + OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 'kATSUFontTag'); end; @@ -729,20 +747,17 @@ begin M := Abs(ALogFont.lfHeight) shl 16; A := @M; S := SizeOf(M); - OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, + OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 'kATSUSizeTag'); end; - // applied when creating text layout - FLineRotation := (ALogFont.lfEscapement shl 16) div 10; - if ALogFont.lfWeight > FW_NORMAL then begin Attr := kATSUQDBoldfaceTag; B := True; A := @B; S := SizeOf(B); - OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, + OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 'kATSUQDBoldfaceTag'); end; @@ -752,7 +767,7 @@ begin B := True; A := @B; S := SizeOf(B); - OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, SSetAttrs, + OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 'kATSUQDItalicTag'); end; @@ -762,7 +777,7 @@ begin B := True; A := @B; S := SizeOf(B); - OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, + OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 'kATSUQDUnderlineTag'); end; @@ -772,7 +787,7 @@ begin B := True; A := @B; S := SizeOf(B); - OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, + OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 'kATSUStyleStrikeThroughTag'); end; end; diff --git a/lcl/interfaces/carbon/carbonlclintf.inc b/lcl/interfaces/carbon/carbonlclintf.inc index b1d72a571f..44312a8b43 100644 --- a/lcl/interfaces/carbon/carbonlclintf.inc +++ b/lcl/interfaces/carbon/carbonlclintf.inc @@ -136,9 +136,15 @@ begin Result:=inherited GetControlConstraints(Constraints); end; +{------------------------------------------------------------------------------ + Method: GetDesignerDC + Params: WindowHandle - Handle of window + Returns: Device context for window designer + ------------------------------------------------------------------------------} function TCarbonWidgetSet.GetDesignerDC(WindowHandle: HWND): HDC; begin - Result:=inherited GetDesignerDC(WindowHandle); + // TODO: create frontmost control for designer context + Result := GetDC(WindowHandle); end; {------------------------------------------------------------------------------ diff --git a/lcl/interfaces/carbon/carbonproc.pp b/lcl/interfaces/carbon/carbonproc.pp index 9a149a93fb..ee7303ef28 100644 --- a/lcl/interfaces/carbon/carbonproc.pp +++ b/lcl/interfaces/carbon/carbonproc.pp @@ -66,6 +66,8 @@ function GetCarbonShiftState: TShiftState; function ShiftStateToModifiers(const Shift: TShiftState): Byte; function FindCarbonFontID(const FontName: String): ATSUFontID; +function CarbonFontIDToFontName(ID: ATSUFontID): String; + function FontStyleToQDStyle(const AStyle: TFontStyles): FPCMacOSAll.Style; procedure FillStandardDescription(out Desc: TRawImageDescription); @@ -379,6 +381,35 @@ begin end; end; +{------------------------------------------------------------------------------ + Name: CarbonFontIDToFontName + Params: IS - Carbon font ID + Returns: The font name, UTF-8 encoded + ------------------------------------------------------------------------------} +function CarbonFontIDToFontName(ID: ATSUFontID): String; +var + NameLength: LongWord; + FontName: UTF8String; +const + SName = 'CarbonFontIDToFontName'; +begin + Result := ''; + + // retrieve font name length + if OSError(ATSUFindFontName(ID, kFontFamilyName, kFontMacintoshPlatform, + kFontRomanScript, kFontEnglishLanguage, NameLength, nil, + @NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Exit; + + SetLength(FontName, NameLength); + + // retrieve font name + if OSError(ATSUFindFontName(ID, kFontFamilyName, kFontMacintoshPlatform, + kFontRomanScript, kFontEnglishLanguage, NameLength, + @FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Exit; + + Result := FontName; +end; + {------------------------------------------------------------------------------ Name: FontStyleToQDStyle Params: AStyle - Font style diff --git a/lcl/interfaces/carbon/carbonwinapi.inc b/lcl/interfaces/carbon/carbonwinapi.inc index d490e30a34..232fbbaf7b 100644 --- a/lcl/interfaces/carbon/carbonwinapi.inc +++ b/lcl/interfaces/carbon/carbonwinapi.inc @@ -663,7 +663,7 @@ end; function TCarbonWidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; LParam: Lparam; flags: dword): Longint; var - FamilyCount, NameLength: LongWord; + FamilyCount: LongWord; FamilyListPtr, PFamily: ^ATSUFontID; FontName: UTF8String; EnumLogFont: TEnumLogFontEx; @@ -698,18 +698,7 @@ begin PFamily := FamilyListPtr; for I := 0 to Pred(FamilyCount) do begin - // retrieve font name length - if OSError(ATSUFindFontName(PFamily^, kFontFamilyName, kFontMacintoshPlatform, - kFontRomanScript, kFontEnglishLanguage, NameLength, nil, - @NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Continue; - - SetLength(FontName, NameLength); - - // retrieve font name, UTF-16 encoded - if OSError(ATSUFindFontName(PFamily^, kFontFamilyName, kFontMacintoshPlatform, - kFontRomanScript, kFontEnglishLanguage, NameLength, - @FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Continue; - + FontName := CarbonFontIDToFontName(PFamily^); if FontName <> '' then // execute callback begin FillChar(EnumLogFont, SizeOf(EnumLogFont), #0); diff --git a/lcl/interfaces/carbon/carbonwsdialogs.pp b/lcl/interfaces/carbon/carbonwsdialogs.pp index 855d96a585..ef0f086556 100644 --- a/lcl/interfaces/carbon/carbonwsdialogs.pp +++ b/lcl/interfaces/carbon/carbonwsdialogs.pp @@ -33,7 +33,7 @@ uses // libs FPCMacOSAll, // LCL - Classes, SysUtils, Controls, Dialogs, LCLType, LCLProc, Masks, + Classes, SysUtils, Controls, Dialogs, LCLType, LCLProc, Masks, Graphics, // widgetset WSLCLClasses, WSProc, WSDialogs, // LCL Carbon @@ -105,13 +105,14 @@ type private protected public + class procedure ShowModal(const ACommonDialog: TCommonDialog); override; end; implementation uses - CarbonProc, CarbonDbgConsts; + CarbonProc, CarbonDbgConsts, CarbonInt, CarbonUtils, CarbonGDIObjects; { TCarbonWSFileDialog } @@ -196,7 +197,6 @@ var FileURL: CFURLRef; FileCFStr: CFStringRef; Filters: TParseStringList; - I: Integer; begin {$IFDEF VerboseWSClass} DebugLn('TCarbonWSFileDialog.ShowModal for ' + ACommonDialog.Name); @@ -378,6 +378,187 @@ begin end; end; +var + FontDialog: TFontDialog; + +{ TCarbonWSFontDialog } + +function CarbonFontDialog_Selection(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +var + AFontDialog: TFontDialog; + ID: ATSUFontID; + Size: Fixed; + Color: RGBColor; + Style: FMFontStyle; +const + SName = 'CarbonFontDialog_Selection'; +begin + {$IFDEF VerboseWSClass} + DebugLn('CarbonFontDialog_Selection: ', DbgSName(FontDialog)); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + // get font panel settings + + if GetEventParameter(AEvent, kEventParamATSUFontID, typeATSUFontID, + nil, SizeOf(ID), nil, @ID) = noErr then + begin + DebugLn('ID: ' + DbgS(ID)); + FontDialog.Font.Name := CarbonFontIDToFontName(ID); + end; + + if GetEventParameter(AEvent, kEventParamATSUFontSize, typeATSUSize, + nil, SizeOf(Size), nil, @Size) = noErr then + begin + DebugLn('Size: ' + DbgS(RoundFixed(Size))); + FontDialog.Font.Size := RoundFixed(Size); + end; + + if GetEventParameter(AEvent, kEventParamFontColor, typeFontColor, + nil, SizeOf(Color), nil, @Color) = noErr then + begin + DebugLn('Color: ' + DbgS(RGBColorToColor(Color))); + FontDialog.Font.Color := RGBColorToColor(Color); + end; + + if GetEventParameter(AEvent, kEventParamFMFontStyle, typeFMFontStyle, + nil, SizeOf(Style), nil, @Style) = noErr then + begin + DebugLn('Style: ' + DbgS(Style)); + FontDialog.Font.Style := []; + if (Style and FPCMacOSAll.bold) > 0 then + FontDialog.Font.Style := FontDialog.Font.Style + [fsBold]; + if (Style and FPCMacOSAll.italic) > 0 then + FontDialog.Font.Style := FontDialog.Font.Style + [fsItalic]; + if (Style and FPCMacOSAll.underline) > 0 then + FontDialog.Font.Style := FontDialog.Font.Style + [fsUnderline]; + end; + + // TODO: fsStrikeOut + + FontDialog.UserChoice := mrOK; +end; + +function CarbonFontDialog_Close(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +var + AFontDialog: TFontDialog; +begin + {$IFDEF VerboseWSClass} + DebugLn('CarbonFontDialog_Close: ', DbgSName(FontDialog)); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + CarbonWidgetSet.SetMainMenuEnabled(True); + + // hide font panel + if FPIsFontPanelVisible then + OSError(FPShowHideFontPanel, 'CarbonFontDialog_Close', 'FPShowHideFontPanel'); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWSFontDialog.ShowModal + Params: ACommonDialog - LCL font dialog + + Shows Carbon interface font panel + ------------------------------------------------------------------------------} +class procedure TCarbonWSFontDialog.ShowModal(const ACommonDialog: TCommonDialog); +var + AFontDialog: TFontDialog; + TmpSpec: EventTypeSpec; + Dialog: WindowRef; + Style: ATSUStyle; + ID: ATSUFontID; + M: ATSUTextMeasurement; + C: RGBColor; + Attr: ATSUAttributeTag; + S: ByteCount; + A: ATSUAttributeValuePtr; +begin + {$IFDEF VerboseWSClass} + DebugLn('TCarbonWSFontDialog.ShowModal for ' + ACommonDialog.Name); + {$ENDIF} + + AFontDialog := ACommonDialog as TFontDialog; + AFontDialog.UserChoice := mrCancel; + + if OSError( + CreateNewWindow(kModalWindowClass, + kWindowCompositingAttribute or kWindowStandardHandlerAttribute, GetCarbonRect(0, 0, 0, 0), Dialog), + Self, SShowModal, 'CreateNewWindow') then Exit; + + try + TmpSpec := MakeEventSpec(kEventClassFont, kEventFontPanelClosed); + InstallWindowEventHandler(Dialog, + RegisterEventHandler(@CarbonFontDialog_Close), + 1, @TmpSpec, nil, nil); + + TmpSpec := MakeEventSpec(kEventClassFont, kEventFontSelection); + InstallWindowEventHandler(Dialog, + RegisterEventHandler(@CarbonFontDialog_Selection), + 1, @TmpSpec, nil, nil); + + + OSError(ATSUCreateAndCopyStyle(TCarbonFont(AFontDialog.Font.Handle).Style, Style), + Self, SShowModal, 'ATSUCreateAndCopyStyle'); + + // force set font ID + if ATSUGetAttribute(Style, kATSUFontTag, SizeOf(ID), @ID, nil) = kATSUNotSetErr then + begin + Attr := kATSUFontTag; + A := @ID; + S := SizeOf(ID); + OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SShowModal, + 'ATSUSetAttributes', 'kATSUFontTag'); + end; + + // force set font size + if ATSUGetAttribute(Style, kATSUSizeTag, SizeOf(M), @M, nil) = kATSUNotSetErr then + begin + Attr := kATSUSizeTag; + A := @M; + S := SizeOf(M); + OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SShowModal, + 'ATSUSetAttributes', 'kATSUSizeTag'); + end; + + // force set font color + if ATSUGetAttribute(Style, kATSUColorTag, SizeOf(C), @C, nil) = kATSUNotSetErr then + begin + Attr := kATSUColorTag; + A := @C; + S := SizeOf(C); + OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SShowModal, + 'ATSUSetAttributes', 'kATSUSizeTag'); + end; + + if OSError(SetFontInfoForSelection(kFontSelectionATSUIType, 1, + @Style, GetWindowEventTarget(Dialog)), + Self, SShowModal, 'SetFontInfoForSelection') then Exit; + + CarbonWidgetSet.SetMainMenuEnabled(False); + + FontDialog := AFontDialog; + FPCMacOSAll.ShowWindow(Dialog); + + // show font panel + if not FPIsFontPanelVisible then + OSError(FPShowHideFontPanel, Self, SShowModal, 'FPShowHideFontPanel'); + + while FPIsFontPanelVisible do + CarbonWidgetSet.AppProcessMessages; + + finally + DisposeWindow(Dialog); + CarbonWidgetSet.SetMainMenuEnabled(True); + end; +end; + initialization //////////////////////////////////////////////////// @@ -393,6 +574,6 @@ initialization // RegisterWSComponent(TSelectDirectoryDialog, TCarbonWSSelectDirectoryDialog); RegisterWSComponent(TColorDialog, TCarbonWSColorDialog); // RegisterWSComponent(TColorButton, TCarbonWSColorButton); -// RegisterWSComponent(TFontDialog, TCarbonWSFontDialog); + RegisterWSComponent(TFontDialog, TCarbonWSFontDialog); //////////////////////////////////////////////////// end.