mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-06-21 02:48:15 +02:00
684 lines
23 KiB
ObjectPascal
684 lines
23 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
* CarbonWSDialogs.pp *
|
|
* -------------- *
|
|
* *
|
|
* *
|
|
*****************************************************************************
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
unit CarbonWSDialogs;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
// defines
|
|
{$I carbondefines.inc}
|
|
|
|
uses
|
|
// libs
|
|
MacOSAll,
|
|
// LCL
|
|
Classes, SysUtils, FileUtil, Controls, Dialogs, LCLType, LCLProc, Masks,
|
|
LazFileUtils, Graphics,
|
|
// widgetset
|
|
WSLCLClasses, WSDialogs,
|
|
// LCL Carbon
|
|
CarbonDef;
|
|
|
|
type
|
|
|
|
{ TCarbonWSCommonDialog }
|
|
|
|
TCarbonWSCommonDialog = class(TWSCommonDialog)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSFileDialog }
|
|
|
|
TCarbonWSFileDialog = class(TWSFileDialog)
|
|
published
|
|
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
|
|
end;
|
|
|
|
{ TCarbonWSOpenDialog }
|
|
|
|
TCarbonWSOpenDialog = class(TWSOpenDialog)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSSaveDialog }
|
|
|
|
TCarbonWSSaveDialog = class(TWSSaveDialog)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSSelectDirectoryDialog }
|
|
|
|
TCarbonWSSelectDirectoryDialog = class(TWSSelectDirectoryDialog)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSColorDialog }
|
|
|
|
TCarbonWSColorDialog = class(TWSColorDialog)
|
|
published
|
|
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
|
|
end;
|
|
|
|
{ TCarbonWSColorButton }
|
|
|
|
TCarbonWSColorButton = class(TWSColorButton)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSFontDialog }
|
|
|
|
TCarbonWSFontDialog = class(TWSFontDialog)
|
|
published
|
|
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
CarbonProc, CarbonDbgConsts, CarbonInt, CarbonUtils, CarbonGDIObjects;
|
|
|
|
{ TCarbonWSFileDialog }
|
|
|
|
var
|
|
Filters: TStringList; // filter text + TMaskList in object
|
|
|
|
procedure DescListToFiles(DescList: AEDescListPtr; FileDialog: TFileDialog);
|
|
var
|
|
FileCount, FileIdx: Integer;
|
|
Keyword: AEKeyword;
|
|
FileDesc: AEDesc;
|
|
FileRef: FSRef;
|
|
FileURL: CFURLRef;
|
|
FileCFStr: CFStringRef;
|
|
FileName: string;
|
|
begin
|
|
//DebugLnEnter('DescListToFiles INIT');
|
|
//if OSError(NavDialogGetReply(DialogRef, DialogReply{%H-}), Self, SShowModal,
|
|
// 'NavDialogGetReply') then Exit; // Get user's selection
|
|
//
|
|
FileDialog.Files.Clear;
|
|
|
|
if DescList=nil then begin
|
|
DebugLnExit('DescList is nil, EXIT');
|
|
exit;
|
|
end;
|
|
|
|
if (DescList=nil) or OSError(AECountItems(DescList^, FileCount{%H-}), FileDialog,
|
|
SShowModal, 'AECountItems') then Exit;
|
|
|
|
for FileIdx := 1 to FileCount do
|
|
begin
|
|
if OSError(AEGetNthDesc(DescList^, FileIdx, typeFSRef,
|
|
@Keyword, FileDesc{%H-}), FileDialog, SShowModal, 'AEGetNthDesc') then Exit;
|
|
|
|
// Get file reference
|
|
if OSError(AEGetDescData(FileDesc, @FileRef, SizeOf(FSRef)), FileDialog,
|
|
SShowModal, 'AEGetDescData') then Exit;
|
|
|
|
if OSError(AEDisposeDesc(FileDesc), FileDialog, SShowModal,
|
|
'AEDisposeDesc') then Exit;
|
|
|
|
FileURL := CFURLCreateFromFSRef(kCFAllocatorDefault, FileRef); // Get URL
|
|
FileCFStr := CFURLCopyFileSystemPath(FileURL, kCFURLPOSIXPathStyle); // Get path
|
|
FileName := CFStringToStr(FileCFStr);
|
|
//DebugLn('%d/%d FileName=%s',[FileIdx, FileCount, FileName]);
|
|
FileDialog.Files.Add(FileName);
|
|
|
|
FreeCFString(FileURL);
|
|
FreeCFString(FileCFStr);
|
|
// Note: Previous 5 lines replace next 2 lines and eliminate need
|
|
// to decide what size to make FileBuf array.
|
|
// See http://developer.apple.com/technotes/tn2002/tn2078.html
|
|
// FSRefMakePath(FileRef, @FileBuf, SizeOf(FileBuf)); {Get file path}
|
|
// FileDialog.Files.Add(string(FileBuf)); //FileBuf contains UTF8 C string
|
|
end;
|
|
|
|
FileDialog.FileName := FileDialog.Files.Strings[0];
|
|
|
|
//if FileDialog.FCompStyle=csSaveFileDialog then
|
|
// FileDialog.FileName := FileDialog.FileName + PathDelim +
|
|
// CFStringToStr(NavDialogGetSaveFileName(DialogRef));
|
|
// {Note: Not at all clear from Apple docs that NavReplyRecord.Selection
|
|
// returns only path to file's folder with Save dialog. Also, what they
|
|
// mean by the "full file name" returned by NavDialogGetSaveFileName
|
|
// must mean extension and not path to file's folder.}
|
|
|
|
|
|
// Dispose of data that record points to (?)
|
|
//if OSError(NavDisposeReply(DialogReply), FileDialog, SShowModal,
|
|
// 'NavDisposeReply') then Exit;
|
|
|
|
//FileDialog.FilterIndex := FilterIndex + 1;
|
|
//DebugLnExit('DescListToFiles END Files.Count=%d',[FileDialog.Files.Count]);
|
|
end;
|
|
|
|
function FilterCallback(var theItem: AEDesc; info: NavFileOrFolderInfoPtr;
|
|
callbackUD: UnivPtr; {%H-}filterMode: NavFilterModes): Boolean; mwpascal;
|
|
{Custom filter callback function. Pointer to this function is passed as
|
|
inFilterProc to NavCreateGetFileDialog and NavCreateChooseFolderDialog.
|
|
If theItem file should be highlighted in file dialog, return True;
|
|
if it should be dimmed in file dialog, return False.
|
|
The callbackUD param contains file dialog object passed as inClientData
|
|
to NavCreateGetFileDialog and NavCreateChooseFolderDialog.}
|
|
var
|
|
FileRef: FSRef;
|
|
FileURL: CFURLRef;
|
|
FileCFStr: CFStringRef;
|
|
FilePath: string;
|
|
FilterMask: TMaskList;
|
|
FileDialog: TFileDialog;
|
|
AIndex: Integer;
|
|
begin
|
|
Result := True;
|
|
FileDialog := TFileDialog(CallbackUD);
|
|
if (FileDialog = nil) or (FileDialog.Filter='') then // No user data passed?
|
|
Exit;
|
|
|
|
if FileDialog is TOpenDialog then
|
|
begin
|
|
if info^.isFolder then // Don't dim folder?
|
|
Exit;
|
|
end
|
|
else {Must be TSelectDirectoryDialog}
|
|
begin
|
|
if not info^.isFolder then // Dim file?
|
|
begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
if OSError(AEGetDescData(theItem, @FileRef, SizeOf(FSRef)),
|
|
'FilterByExtCallback', '', 'AEGetDescData') then Exit;
|
|
|
|
FileURL := CFURLCreateFromFSRef(kCFAllocatorDefault, FileRef);
|
|
FileCFStr := CFURLCopyFileSystemPath(FileURL, kCFURLPOSIXPathStyle);
|
|
|
|
FilePath := CFStringToStr(FileCFStr);
|
|
|
|
FreeCFString(FileURL);
|
|
FreeCFString(FileCFStr);
|
|
|
|
FilterMask := nil;
|
|
AIndex := FileDialog.FilterIndex - 1;
|
|
if (AIndex >= 0) and (AIndex < Filters.Count) then
|
|
FilterMask := TMaskList(Filters.Objects[AIndex]);
|
|
|
|
Result := (FilterMask = nil) or FilterMask.Matches(ExtractFilename(FilePath));
|
|
//DebugLn('FilterCallback ' + DbgS(FilterMask) + ' ' + ExtractFilename(FilePath) + ' ' + DbgS(Result));
|
|
end; {FilterCallback}
|
|
|
|
procedure NavDialogCallback(CallBackSelector: NavEventCallbackMessage;
|
|
CallBackParms: NavCBRecPtr; CallBackUD: UnivPtr); mwpascal;
|
|
var
|
|
Dir: AEDesc;
|
|
DirRef: FSRef;
|
|
DirURL: CFURLRef;
|
|
DirCFStr: CFStringRef;
|
|
PMenuSpec: NavMenuItemSpecPtr;
|
|
MenuSpec: NavMenuItemSpec;
|
|
AEDescList: AEDescListPtr;
|
|
FileDialog: TFileDialog;
|
|
const
|
|
SName = 'NavDialogCallback';
|
|
begin
|
|
//DebugLnEnter(['NavDialogCallback INIT selector=',CallbackSelector]);
|
|
if CallbackUD = nil then // No user data passed?
|
|
Exit;
|
|
FileDialog := TFileDialog(CallbackUD);
|
|
|
|
case CallBackSelector of
|
|
kNavCBStart:
|
|
begin
|
|
|
|
// Set InitialDir
|
|
if DirectoryExistsUTF8(FileDialog.InitialDir) then
|
|
begin
|
|
//DebugLn('Set InitialDir ' + TFileDialog(CallbackUD).InitialDir);
|
|
CreateCFString(FileDialog.InitialDir, DirCFStr);
|
|
try
|
|
DirURL := CFURLCreateWithFileSystemPath(nil, DirCFStr,
|
|
kCFURLPOSIXPathStyle, True);
|
|
finally
|
|
FreeCFString(DirCFStr);
|
|
end;
|
|
|
|
if DirURL <> nil then
|
|
if CFURLGetFSRef(DirURL, DirRef{%H-}) then
|
|
if not OSError(AECreateDesc(typeFSRef, @DirRef, SizeOf(FSRef), Dir{%H-}),
|
|
SName, 'AECreateDesc') then
|
|
OSError(NavCustomControl(CallBackParms^.context, kNavCtlSetLocation, @Dir),
|
|
SName, 'NavCustomControl', 'InitialDir');
|
|
end;
|
|
|
|
// set initial filter index
|
|
MenuSpec.version := kNavMenuItemSpecVersion;
|
|
MenuSpec.menuCreator := kExtensionFolderType;
|
|
MenuSpec.menuType := OSType(FileDialog.FilterIndex-1);
|
|
MenuSpec.menuItemName := '';
|
|
OSError(NavCustomControl(CallBackParms^.context, kNavCtlSelectCustomType, @MenuSpec),
|
|
SName, 'NavCustomControl', 'FilterIndex');
|
|
|
|
end;
|
|
kNavCBPopupMenuSelect: // user has changed filter
|
|
begin
|
|
if CallBackParms = nil then Exit;
|
|
PMenuSpec := NavMenuItemSpecPtr(CallBackParms^.eventData.eventDataParms.param);
|
|
if PMenuSpec = nil then Exit;
|
|
FileDialog.IntfFileTypeChanged(PMenuSpec^.menuType + 1);
|
|
end;
|
|
kNavCBSelectEntry: // user has selected something
|
|
begin
|
|
if CallbackParms = nil then exit;
|
|
AEDescList := AEDescListPtr(CallBackParms^.eventData.eventDataParms.param);
|
|
DescListToFiles(AEDescList, FileDialog);
|
|
//DebugLn(['kNavCBSelectEntry IsOpenDialog=',FileDialog is TOpenDialog]);
|
|
if FileDialog is TOpenDialog then
|
|
TOpenDialog(FileDialog).DoSelectionChange;
|
|
end;
|
|
kNavCBNewLocation: // user has changed folder
|
|
if FileDialog is TOpenDialog then
|
|
TOpenDialog(FileDialog).DoFolderChange;
|
|
end;
|
|
|
|
//DebugLnExit('NavDialogCallback DONE');
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSFileDialog.ShowModal
|
|
Params: ACommonDialog - LCL common dialog
|
|
|
|
Shows a file dialog (open, save, slect directory) in Carbon interface. Sets
|
|
ACommonDialog.UserChoice to mrOK or mrCancel. If mrOK, also sets
|
|
ACommonDialog.FileName to first file selected and adds file(s) selected to
|
|
ACommonDialog.Files.
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSFileDialog.ShowModal(const ACommonDialog: TCommonDialog);
|
|
{
|
|
Called by Execute method of TOpenDialog, TSaveDialog and TSelectDirectoryDialog.
|
|
}
|
|
var
|
|
FileDialog: TFileDialog;
|
|
CreationOptions: NavDialogCreationOptions;
|
|
FilterUPP: NavObjectFilterUPP;
|
|
NavDialogUPP: NavEventUPP;
|
|
DialogRef: NavDialogRef;
|
|
ReplyRecord: NavReplyRecord;
|
|
I: Integer;
|
|
ParsedFilter: TParseStringList;
|
|
M: TMaskList;
|
|
filterext: String;
|
|
supportPackages: Boolean; //todo: select packages by name
|
|
begin
|
|
{$IFDEF VerboseWSClass}
|
|
DebugLn('TCarbonWSFileDialog.ShowModal for ' + ACommonDialog.Name);
|
|
{$ENDIF}
|
|
|
|
FileDialog := ACommonDialog as TFileDialog;
|
|
|
|
// Initialize record to default values
|
|
if OSError(NavGetDefaultDialogCreationOptions(CreationOptions{%H-}),
|
|
Self, SShowModal, 'NavGetDefaultDialogCreationOptions') then Exit;
|
|
|
|
CreationOptions.preferenceKey := 272829; // The default of zero seems to cause setting the initial directory
|
|
// to fail half the time on Sierra at least, so set to an arbitrary
|
|
// non-zero value
|
|
if FileDialog.Title <> '' then // Override dialog's default title?
|
|
CreateCFString(FileDialog.Title, CreationOptions.windowTitle);
|
|
|
|
FileDialog.UserChoice := mrCancel; // Return this if user cancels or we need to exit
|
|
|
|
FilterUPP := NewNavObjectFilterUPP(NavObjectFilterProcPtr(@FilterCallback));
|
|
NavDialogUPP := NewNavEventUPP(NavEventProcPtr(@NavDialogCallback));
|
|
|
|
Filters := TStringList.Create;
|
|
// parse filters to popup menu - filter text + TMaskList
|
|
ParsedFilter := TParseStringList.Create(FileDialog.Filter, '|');
|
|
try
|
|
for I := 1 to ParsedFilter.Count div 2 do
|
|
begin
|
|
try
|
|
filterext:=ParsedFilter[I * 2 - 1];
|
|
{ Spaces in filters cause problems }
|
|
filterext := StringReplace(filterext, ' ', '', [rfReplaceAll]);
|
|
if (filterext = '*') or (filterext = '*.*') or (ExtractFileExt(filterext) = '.app') then
|
|
supportPackages := true;
|
|
M := TMaskList.Create(filterext);
|
|
except
|
|
FreeAndNil(M);
|
|
end;
|
|
//DebugLn('Filter ' + ParsedFilter[I * 2 - 1]);
|
|
Filters.AddObject(ParsedFilter[I * 2 - 2], M);
|
|
end;
|
|
finally
|
|
ParsedFilter.Free;
|
|
end;
|
|
supportPackages:=supportPackages or (Filters.Count=0);
|
|
|
|
CreationOptions.popupExtension := StringsToCFArray(Filters);
|
|
if supportPackages then
|
|
CreationOptions.optionFlags := CreationOptions.optionFlags or kNavSupportPackages;
|
|
try
|
|
if FileDialog.FCompStyle=csSaveFileDialog then
|
|
begin // Checking for TSaveDialog first since it's descendent of TOpenDialog
|
|
CreateCFString(ExtractFileName(FileDialog.FileName),
|
|
CreationOptions.saveFileName); // Note doesn't like path
|
|
|
|
if ofOverwritePrompt in TOpenDialog(FileDialog).Options then
|
|
CreationOptions.optionFlags :=
|
|
CreationOptions.optionFlags and (not kNavDontConfirmReplacement)
|
|
else
|
|
CreationOptions.optionFlags :=
|
|
CreationOptions.optionFlags or kNavDontConfirmReplacement;
|
|
|
|
// Create Save dialog
|
|
if OSError(
|
|
NavCreatePutFileDialog(@CreationOptions, 0, 0, NavDialogUPP,
|
|
UnivPtr(FileDialog), DialogRef{%H-}),
|
|
Self, SShowModal, 'NavCreatePutFileDialog') then Exit;
|
|
end
|
|
else
|
|
if FileDialog is TSelectDirectoryDialog then // Create Choose folder dialog
|
|
begin
|
|
if OSError(
|
|
NavCreateChooseFolderDialog(@CreationOptions, NavDialogUPP,
|
|
FilterUPP, UnivPtr(FileDialog), DialogRef),
|
|
Self, SShowModal, 'NavCreateChooseFolderDialog') then Exit;
|
|
end
|
|
else
|
|
if FileDialog is TOpenDialog then
|
|
begin
|
|
if not (ofAllowMultiSelect in TOpenDialog(FileDialog).Options) then
|
|
CreationOptions.optionFlags :=
|
|
CreationOptions.optionFlags and (not kNavAllowMultipleFiles)
|
|
else
|
|
CreationOptions.optionFlags :=
|
|
CreationOptions.optionFlags or kNavAllowMultipleFiles;
|
|
|
|
// Create Open dialog
|
|
if OSError(
|
|
NavCreateGetFileDialog(@CreationOptions, nil, NavDialogUPP, nil,
|
|
FilterUPP, UnivPtr(FileDialog), DialogRef),
|
|
Self, SShowModal, 'NavCreateGetFileDialog') then Exit;
|
|
end;
|
|
|
|
try
|
|
// Display dialog
|
|
FileDialog.Handle := THandle(PtrUInt(DialogRef));
|
|
if OSError(NavDialogRun(DialogRef), Self, SShowModal, 'NavDialogRun') then Exit;
|
|
|
|
if NavDialogGetUserAction(DialogRef) <> kNavUserActionCancel then // User OK?
|
|
begin
|
|
if OSError(NavDialogGetReply(DialogRef, ReplyRecord), Self, SShowModal, 'NavDialogGetReply') then
|
|
Exit;
|
|
try
|
|
if not ReplyRecord.validRecord then
|
|
Exit;
|
|
DescListToFiles(@ReplyRecord.selection, FileDialog);
|
|
if FileDialog.FCompStyle=csSaveFileDialog then
|
|
FileDialog.FileName := FileDialog.FileName + PathDelim + CFStringToStr(ReplyRecord.saveFileName);
|
|
finally
|
|
NavDisposeReply(ReplyRecord);
|
|
end;
|
|
FileDialog.UserChoice := mrOK;
|
|
end;
|
|
finally
|
|
NavDialogDispose(DialogRef); // Dispose of dialog
|
|
end;
|
|
|
|
finally
|
|
CFRelease(CreationOptions.popupExtension);
|
|
for I := 0 to Filters.Count - 1 do
|
|
if Filters.Objects[I] <> nil then Filters.Objects[I].Free;
|
|
Filters.Free;
|
|
|
|
DisposeNavObjectFilterUPP(FilterUPP);
|
|
DisposeNavEventUPP(NavDialogUPP);
|
|
FreeCFString(CreationOptions.windowTitle);
|
|
FreeCFString(CreationOptions.saveFileName);
|
|
end;
|
|
end; {TCarbonWSFileDialog.ShowModal}
|
|
|
|
{ TCarbonWSColorDialog }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSColorDialog.ShowModal
|
|
Params: ACommonDialog - LCL color dialog
|
|
|
|
Shows Carbon interface color picker
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSColorDialog.ShowModal(
|
|
const ACommonDialog: TCommonDialog);
|
|
var
|
|
ColorInfo: NColorPickerInfo;
|
|
ColorDialog: TColorDialog;
|
|
Profile: CMProfileRef;
|
|
begin
|
|
{$IFDEF VerboseWSClass}
|
|
DebugLn('TCarbonWSColorDialog.ShowModal for ' + ACommonDialog.Name);
|
|
{$ENDIF}
|
|
|
|
ACommonDialog.UserChoice := mrCancel;
|
|
ColorDialog := ACommonDialog as TColorDialog;
|
|
|
|
CMGetDefaultProfileBySpace(cmRGBData, Profile{%H-});
|
|
FillChar(ColorInfo{%H-}, SizeOf(ColorPickerInfo), 0);
|
|
ColorInfo.theColor.color.rgb := CMRGBColor(ColorToRGBColor(ColorDialog.Color));
|
|
ColorInfo.theColor.profile := Profile;
|
|
ColorInfo.dstProfile := Profile;
|
|
ColorInfo.flags := kColorPickerDialogIsModal or
|
|
kColorPickerDialogIsMoveable;
|
|
ColorInfo.placeWhere := kCenterOnMainScreen;
|
|
ColorInfo.pickerType := 0; // use last picker subtype
|
|
ColorInfo.eventProc := nil;
|
|
ColorInfo.colorProc := nil;
|
|
ColorInfo.prompt := ColorDialog.Title; // ColorDialog.Title is ignored, ColorInfo.prompt is not shown anywhere
|
|
|
|
if OSError(NPickColor(ColorInfo), Self, SShowModal, 'PickColor') then Exit;
|
|
|
|
if ColorInfo.newColorChosen then
|
|
begin
|
|
ColorDialog.Color := RGBColorToColor(RGBColor(ColorInfo.theColor.color.rgb));
|
|
ACommonDialog.UserChoice := mrOK;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
FontDialog: TFontDialog;
|
|
|
|
{ TCarbonWSFontDialog }
|
|
|
|
function CarbonFontDialog_Selection(ANextHandler: EventHandlerCallRef;
|
|
AEvent: EventRef;
|
|
{%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
|
|
var
|
|
ID: ATSUFontID;
|
|
Size: Fixed;
|
|
Color: RGBColor;
|
|
Style: FMFontStyle;
|
|
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)));
|
|
//API gives "size" which equals to LCL's height (LCL height has minus)
|
|
FontDialog.Font.Height := -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;
|
|
|
|
{ These styles don't work for most modern fonts, and can result in
|
|
a font being double-bolded now that carbonproc.pp::lclFontName uses
|
|
the full name (including style), rather than just the family name.
|
|
|
|
if GetEventParameter(AEvent, kEventParamFMFontStyle, typeFMFontStyle,
|
|
nil, SizeOf(Style), nil, @Style) = noErr then
|
|
begin
|
|
//DebugLn('Style: ' + DbgS(Style));
|
|
FontDialog.Font.Style := [];
|
|
if (Style and MacOSAll.bold) > 0 then
|
|
FontDialog.Font.Style := FontDialog.Font.Style + [fsBold];
|
|
if (Style and MacOSAll.italic) > 0 then
|
|
FontDialog.Font.Style := FontDialog.Font.Style + [fsItalic];
|
|
if (Style and MacOSAll.underline) > 0 then
|
|
FontDialog.Font.Style := FontDialog.Font.Style + [fsUnderline];
|
|
end;
|
|
}
|
|
// TODO: fsStrikeOut
|
|
|
|
FontDialog.UserChoice := mrOK;
|
|
end;
|
|
|
|
function CarbonFontDialog_Close(ANextHandler: EventHandlerCallRef;
|
|
AEvent: EventRef;
|
|
{%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
|
|
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 or kWindowFrameworkScaledAttribute, GetCarbonRect(0, 0, 0, 0), Dialog{%H-}),
|
|
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.Reference.Handle).Style, Style{%H-}),
|
|
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;
|
|
MacOSAll.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;
|
|
|
|
end.
|