mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-29 02:43:41 +02:00
803 lines
24 KiB
ObjectPascal
803 lines
24 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
|
|
unit MUIInt;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
{$ifdef Trace}
|
|
{$ASSERTIONS ON}
|
|
{$endif}
|
|
|
|
uses
|
|
// rtl+fcl
|
|
agraphics, Types, Classes, SysUtils, FPCAdds, Math,
|
|
// interfacebase
|
|
InterfaceBase,
|
|
// LCL
|
|
lclplatformdef, Dialogs, Controls, Forms, LCLStrConsts, LMessages, stdctrls,
|
|
LCLProc, LCLIntf, LCLType, GraphType, Graphics, Menus, Themes, muithemes,
|
|
// Amiga units
|
|
MUIBaseUnit, MUIFormsUnit, muidrawing, tagsparamshelper, muiglobal,
|
|
{$ifdef HASAMIGA}
|
|
exec, intuition, mui, utility, AmigaDos, icon,
|
|
cybergraphics,
|
|
inputevent, Cliputils,
|
|
{$endif}
|
|
// widgetset
|
|
WSLCLClasses, LCLMessageGlue;
|
|
|
|
const
|
|
IdButtonTexts: array[idButtonOk..idButtonShield] of string = (
|
|
{ idButtonOk } 'OK',
|
|
{ idButtonCancel } 'Cancel',
|
|
{ idButtonHelp } 'Help',
|
|
{ idButtonYes } 'Yes',
|
|
{ idButtonNo } 'No',
|
|
{ idButtonClose } 'Close',
|
|
{ idButtonAbort } 'Abort',
|
|
{ idButtonRetry } 'Retry',
|
|
{ idButtonIgnore } 'Ignore',
|
|
{ idButtonAll } 'All',
|
|
{ idButtonYesToAll } 'YesToAll',
|
|
{ idButtonNoToAll } 'NoToAll',
|
|
{ idButtonOpen } 'Open',
|
|
{ idButtonSave } 'Save',
|
|
{ idButtonShield } 'Shield'
|
|
);
|
|
type
|
|
{ TMUIWidgetSet }
|
|
|
|
TMUIWidgetSet = class(TWidgetSet)
|
|
protected
|
|
ThisAppDiskIcon: Pointer;
|
|
function CreateThemeServices: TThemeServices; override;
|
|
function GetAppHandle: TLCLHandle; override;
|
|
public
|
|
procedure PassCmdLineOptions; override;
|
|
public
|
|
function LCLPlatform: TLCLPlatform; override;
|
|
function GetLCLCapability(ACapability: TLCLCapability):PtrUInt; override;
|
|
// Application
|
|
procedure AppInit(var ScreenInfo: TScreenInfo); override;
|
|
procedure AppProcessMessages; override;
|
|
procedure AppWaitMessage; override;
|
|
procedure AppTerminate; override;
|
|
procedure AppMinimize; override;
|
|
procedure AppRestore; override;
|
|
procedure AppBringToFront; override;
|
|
procedure AppSetTitle(const ATitle: string); override;
|
|
function EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint; override;
|
|
//function MessageBox(hWnd: HWND; lpText: PChar; lpCaption: PChar; uType: Cardinal): Integer; override;
|
|
function PromptUser(const DialogCaption: String; const DialogMessage: String; DialogType: LongInt; Buttons: PLongint; ButtonCount: LongInt; DefaultIndex: LongInt; EscapeResult: LongInt):LongInt; override;
|
|
function RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap: HBITMAP; out AMask: HBITMAP; ASkipMask: Boolean = false):Boolean; override;
|
|
function RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): boolean; override;
|
|
function RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean; override;
|
|
function RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean; override;
|
|
function RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean; override;
|
|
function RawImage_QueryDescription(AFlags: TRawImageQueryFlags; var ADesc: TRawImageDescription): Boolean; override;
|
|
function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override;
|
|
procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override;
|
|
function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
|
|
// Clipboard
|
|
function ClipboardFormatToMimeType(FormatID: TClipboardFormat): string; override;
|
|
function ClipboardGetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat; Stream: TStream): boolean; override;
|
|
// ! ClipboardGetFormats: List will be created. You must free it yourself with FreeMem(List) !
|
|
function ClipboardGetFormats(ClipboardType: TClipboardType; var Count: integer; var List: PClipboardFormat): boolean; override;
|
|
function ClipboardGetOwnerShip(ClipboardType: TClipboardType; OnRequestProc: TClipboardRequestEvent; FormatCount: integer; Formats: PClipboardFormat): boolean; override;
|
|
function ClipboardRegisterFormat(const AMimeType: string): TClipboardFormat; override;
|
|
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
|
|
// debugging
|
|
procedure DebugOutEvent(Sender: TObject;s: string; var Handled: Boolean);
|
|
procedure DebugOutLNEvent(Sender: TObject;s: string; var Handled: Boolean);
|
|
|
|
// create and destroy
|
|
function CreateTimer(Interval: integer; TimerFunc: TWSTimerProc) : TLCLHandle; override;
|
|
function DestroyTimer(TimerHandle: TLCLHandle) : boolean; override;
|
|
procedure DestroyLCLComponent(Sender: TObject);virtual;
|
|
|
|
{$I muiwinapih.inc}
|
|
public
|
|
end;
|
|
|
|
var
|
|
MUIWidgetSet: TMUIWidgetSet;
|
|
FocusWidget: Hwnd;
|
|
implementation
|
|
|
|
uses
|
|
MUIWSFactory, MUIWSForms, VInfo, muistdctrls, lazloggerbase;
|
|
|
|
|
|
{$I muiwinapi.inc}
|
|
|
|
{ TMUIWidgetSet }
|
|
|
|
function TMUIWidgetSet.GetAppHandle: TLCLHandle;
|
|
begin
|
|
Result := TLCLHandle(MUIApp);
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.PassCmdLineOptions;
|
|
begin
|
|
inherited PassCmdLineOptions;
|
|
end;
|
|
|
|
function TMUIWidgetSet.LCLPlatform: TLCLPlatform;
|
|
begin
|
|
Result:=lpMUI;
|
|
end;
|
|
|
|
function TMUIWidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt;
|
|
begin
|
|
case ACapability of
|
|
lcCanDrawOutsideOnPaint: Result := LCL_CAPABILITY_NO;
|
|
lcDragDockStartOnTitleClick: Result := LCL_CAPABILITY_NO;
|
|
lcNeedMininimizeAppWithMainForm: Result := LCL_CAPABILITY_NO;
|
|
lcAsyncProcess: Result := LCL_CAPABILITY_NO;
|
|
lcApplicationTitle: Result := LCL_CAPABILITY_YES;
|
|
lcApplicationWindow:Result := LCL_CAPABILITY_YES;
|
|
lcFormIcon: Result := LCL_CAPABILITY_NO;
|
|
lcModalWindow: Result := LCL_CAPABILITY_NO;
|
|
lcAntialiasingEnabledByDefault: Result := LCL_CAPABILITY_NO;
|
|
lcLMHelpSupport: Result := LCL_CAPABILITY_NO;
|
|
lcSendsUTF8KeyPress: Result := LCL_CAPABILITY_NO;
|
|
else
|
|
Result := inherited GetLCLCapability(ACapability);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
// MUI does not copy this values, so we keep them here
|
|
AppTitle, FinalVers, Vers, CopyR, Comment, PrgName, Author: string;
|
|
|
|
procedure TMUIWidgetSet.DebugOutEvent(Sender: TObject;s: string; var Handled: Boolean);
|
|
begin
|
|
SysDebugln('(LCL:'+Sender.classname+'): '+ s);
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.DebugOutLNEvent(Sender: TObject;s: string; var Handled: Boolean);
|
|
begin
|
|
SysDebugln('(LCL:'+Sender.classname+'): '+ s);
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppInit(var ScreenInfo: TScreenInfo);
|
|
type
|
|
TVerArray = array[0..3] of Word;
|
|
var
|
|
Info: TVersionInfo;
|
|
i,j: Integer;
|
|
TagList: TATagList;
|
|
Dollar: string;
|
|
|
|
function PV2Str(PV: TVerArray): String;
|
|
begin
|
|
Result := SysUtils.Format('%d.%d.%d.%d', [PV[0],PV[1],PV[2],PV[3]])
|
|
end;
|
|
|
|
begin
|
|
// connect Debug log output
|
|
//DebugLogger.OnDbgOut := @DebugOutEvent;
|
|
//DebugLogger.OnDebugLn := @DebugOutLNEvent;
|
|
// Initial Application Values
|
|
Vers := '';
|
|
CopyR := '';
|
|
Comment := '';
|
|
Dollar := '$';
|
|
// Get the name from Application.Title, remove the Path Part
|
|
PrgName := ExtractFilename(Application.Title);
|
|
AppTitle := PrgName;
|
|
// Miu can't handle empty AppTitle, use Exename
|
|
if AppTitle = '' then
|
|
AppTitle := ExtractFilename(ParamStr(0));
|
|
// load Informations from resource
|
|
Info := TVersionInfo.Create;
|
|
try
|
|
Info.Load(HINSTANCE);
|
|
Vers := PV2Str(Info.FixedInfo.FileVersion);
|
|
for i := 0 to Info.StringFileInfo.Count - 1 do
|
|
begin
|
|
for j := 0 to Info.StringFileInfo.Items[i].Count - 1 do
|
|
begin
|
|
if Info.StringFileInfo.Items[i].Keys[j] = 'LegalCopyright' then
|
|
CopyR := Info.StringFileInfo.Items[i].Values[j]
|
|
else
|
|
if Info.StringFileInfo.Items[i].Keys[j] = 'Comments' then
|
|
Comment := Info.StringFileInfo.Items[i].Values[j]
|
|
else
|
|
if Info.StringFileInfo.Items[i].Keys[j] = 'CompanyName' then
|
|
Author := Info.StringFileInfo.Items[i].Values[j]
|
|
else
|
|
if Info.StringFileInfo.Items[i].Keys[j] = 'ProductName' then
|
|
begin
|
|
if Length(Trim(Info.StringFileInfo.Items[i].Values[j])) > 0 then
|
|
PrgName := Info.StringFileInfo.Items[i].Values[j];
|
|
end;
|
|
end;
|
|
end;
|
|
except
|
|
end;
|
|
// end resource loading
|
|
Info.Free;
|
|
// get the Icon (to use as Iconify Image), nil is no problem, MUI handle that and use the default
|
|
ThisAppDiskIcon := GetDiskObject(PChar(ParamStr(0)));
|
|
// Version information as Standard AMIGA Version string
|
|
FinalVers := Dollar + 'VER: ' + PrgName + ' ' + Vers + '('+{$I %DATE%}+')';
|
|
// Create the Application
|
|
TagList.AddTags([
|
|
NativeInt(MUIA_Application_Base), NativeUInt(PChar(AppTitle)),
|
|
MUIA_Application_DiskObject, NativeUInt(ThisAppDiskIcon),
|
|
MUIA_Application_Title, NativeUInt(PChar(AppTitle)),
|
|
MUIA_Application_Version, NativeUInt(PChar(FinalVers)),
|
|
MUIA_Application_Copyright, NativeUInt(PChar(CopyR)),
|
|
MUIA_Application_Description, NativeUInt(PChar(Comment)),
|
|
MUIA_Application_Author, NativeUInt(PChar(Author))
|
|
]);
|
|
MUIApp := TMuiApplication.Create(TagList);
|
|
if not Assigned(MUIApp) or not Assigned(MUIApp.Obj) then
|
|
raise EInvalidOperation.Create('Unable to Create Application object.');
|
|
// same basic Screen info, no idea where to get that
|
|
ScreenInfo.PixelsPerInchX := 72;
|
|
ScreenInfo.PixelsPerInchY := 72;
|
|
ScreenInfo.ColorDepth := 32;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppProcessMessages;
|
|
begin;
|
|
MuiApp.ProcessMessages;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppWaitMessage;
|
|
begin
|
|
MuiApp.WaitMessages;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppTerminate;
|
|
begin
|
|
FreeDiskObject(ThisAppDiskIcon);
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppMinimize;
|
|
begin
|
|
MuiApp.Iconified := True;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppRestore;
|
|
begin
|
|
MuiApp.Iconified := False;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppBringToFront;
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.AppSetTitle(const ATitle: string);
|
|
begin
|
|
|
|
end;
|
|
|
|
function TMUIWidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont;
|
|
Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint;
|
|
begin
|
|
Result:=0;
|
|
end;
|
|
|
|
(*
|
|
function TMUIWidgetSet.MessageBox(hWnd: HWND; lpText: PChar; lpCaption: PChar;
|
|
uType: Cardinal): Integer;
|
|
begin
|
|
end;*)
|
|
|
|
function TMUIWidgetSet.PromptUser(const DialogCaption: String;
|
|
const DialogMessage: String; DialogType: LongInt; Buttons: PLongint;
|
|
ButtonCount: LongInt; DefaultIndex: LongInt; EscapeResult: LongInt): LongInt;
|
|
var
|
|
ES: PEasyStruct;
|
|
BtnText: string;
|
|
Res: LongInt;
|
|
BtnIdx : LongInt;
|
|
BtnId: LongInt;
|
|
begin
|
|
New(ES);
|
|
ES^.es_StructSize := SizeOf(TEasyStruct);
|
|
ES^.es_Flags := 0;
|
|
ES^.es_Title := PChar(DialogCaption);
|
|
ES^.es_TextFormat := PChar(DialogMessage);
|
|
for BtnIdx := 0 to ButtonCount-1 do
|
|
begin
|
|
BtnID := Buttons[BtnIdx];
|
|
if (BtnID >= Low(IdButtonTexts)) and (BtnID <= High(IdButtonTexts)) then
|
|
begin
|
|
if BtnIdx = 0 then
|
|
BtnText := IdButtonTexts[BtnID]
|
|
else
|
|
BtnText := BtnText + '|'+ IdButtonTexts[BtnID];
|
|
end else
|
|
begin
|
|
if BtnIdx = 0 then
|
|
BtnText := IntToStr(BtnID)
|
|
else
|
|
BtnText := BtnText + '|'+ IntToStr(BtnID);
|
|
end;
|
|
end;
|
|
ES^.es_GadgetFormat := PChar(BtnText);
|
|
{$ifdef MorphOS}
|
|
// App after MUI_RequestA is blocked
|
|
Res := EasyRequestArgs(nil, ES, nil, nil);
|
|
{$else}
|
|
Res := MUI_RequestA(MuiApp.Obj, MuiApp.MainWin, 0, ES^.es_Title, ES^.es_GadgetFormat, ES^.es_TextFormat, nil);
|
|
{$endif}
|
|
Result := EscapeResult;
|
|
Res := Res - 1;
|
|
if Res < 0 then
|
|
Res := ButtonCount - 1;
|
|
if (Res >= 0) and (Res < ButtonCount) then
|
|
Result := Buttons[Res];
|
|
Dispose(ES);
|
|
end;
|
|
|
|
type
|
|
TARGBPixel = packed record
|
|
A: Byte;
|
|
R: Byte;
|
|
G: Byte;
|
|
B: Byte;
|
|
end;
|
|
PARGBPixel = ^TARGBPixel;
|
|
|
|
{TABGRPixel = packed record
|
|
R: Byte;
|
|
G: Byte;
|
|
B: Byte;
|
|
A: Byte;
|
|
end;}
|
|
TABGRPixel = array[0..3] of Byte;
|
|
PABGRPixel = ^TABGRPixel;
|
|
|
|
{.$define VERBOSEAROS}
|
|
|
|
function TMUIWidgetSet.RawImage_CreateBitmaps(const ARawImage: TRawImage; out
|
|
ABitmap: HBITMAP; out AMask: HBITMAP; ASkipMask: Boolean): Boolean;
|
|
var
|
|
Bit: TMUIBitmap;
|
|
//Ridx, GIdx, BIdx, AIdx: Byte;
|
|
begin
|
|
{$ifdef VERBOSEAROS}
|
|
writeln('RawImage_CreateBitmaps ' + IntToStr(ARawImage.Description.Width) + ' x ' + IntToStr(ARawImage.Description.Height) + ' - ' + IntToStr(ARawImage.Description.Depth) + ' = ' + IntToStr(ARawImage.DataSize));
|
|
{$endif}
|
|
Bit := TMUIBitmap.Create(ARawImage.Description.Width, ARawImage.Description.Height, ARawImage.Description.Depth);
|
|
//ARawImage.Description.GetRGBIndices(Ridx, GIdx, BIdx, AIdx);
|
|
//writeln('R: ',Ridx, ' G: ', GIdx, ' B: ', BIdx, ' A: ', AIdx);
|
|
if ARawImage.DataSize > 0 then
|
|
Move(ARawImage.Data^, Bit.FImage^, ARawImage.DataSize);
|
|
//PLongWord(Bit.FImage)^ := $FFFFFFFF;
|
|
ABitmap := HBITMAP(Bit);
|
|
AMask := 0;
|
|
Result := True;
|
|
//writeln('created Bitmap: ', HexStr(Bit), ' width: ', Bit.FWidth, ' ??? ', ARawImage.Description.Width, ' Datasize: ', ARawImage.DataSize);
|
|
//writeln(' create image: ', ARawImage.Description.Width,'x', ARawImage.Description.Height,' : ',ARawImage.Description.Depth, ' - ', ARawImage.DataSize, ' $', HexStr(Bit));
|
|
//writeln(' Desc: ', HexStr(@(ARawImage.Description)));
|
|
end;
|
|
|
|
function RawImage_DescriptionFromDrawable(out
|
|
ADesc: TRawImageDescription; ACustomAlpha: Boolean
|
|
): boolean;
|
|
var
|
|
IsBitmap: Boolean;
|
|
begin
|
|
{$ifdef VERBOSEAROS}
|
|
writeln('RawImage_DescriptionFromDrawable');
|
|
{$endif}
|
|
//writeln('GetDescription from Drawable');
|
|
IsBitMap := False;
|
|
|
|
ADesc.Init;
|
|
ADesc.Width := cardinal(0);
|
|
ADesc.Height := cardinal(0);
|
|
ADesc.BitOrder := riboBitsInOrder;
|
|
ADesc.PaletteColorCount := 0;
|
|
if ACustomAlpha then
|
|
begin
|
|
// always give pixbuf description for alpha images
|
|
ADesc.Format:=ricfRGBA;
|
|
ADesc.Depth := 32;
|
|
ADesc.BitsPerPixel := 32;
|
|
ADesc.LineEnd := rileDWordBoundary;
|
|
ADesc.ByteOrder := riboLSBFirst;
|
|
|
|
ADesc.RedPrec := 8;
|
|
ADesc.RedShift := 0;
|
|
ADesc.GreenPrec := 8;
|
|
ADesc.GreenShift := 8;
|
|
ADesc.BluePrec := 8;
|
|
ADesc.BlueShift := 16;
|
|
ADesc.AlphaPrec := 8;
|
|
ADesc.AlphaShift := 24;
|
|
|
|
ADesc.MaskBitsPerPixel := 1;
|
|
ADesc.MaskShift := 0;
|
|
ADesc.MaskLineEnd := rileByteBoundary;
|
|
ADesc.MaskBitOrder := riboBitsInOrder;
|
|
|
|
Exit(True);
|
|
end;
|
|
|
|
// Format
|
|
if IsBitmap then
|
|
begin
|
|
ADesc.Format := ricfGray;
|
|
end else
|
|
begin
|
|
ADesc.Format:=ricfRGBA;
|
|
ADesc.RedPrec := 8;
|
|
ADesc.RedShift := 0;
|
|
ADesc.GreenPrec := 8;
|
|
ADesc.GreenShift := 8;
|
|
ADesc.BluePrec := 8;
|
|
ADesc.BlueShift := 16;
|
|
ADesc.AlphaPrec := 8;
|
|
ADesc.AlphaShift := 24;
|
|
|
|
ADesc.MaskBitsPerPixel := 1;
|
|
ADesc.MaskShift := 0;
|
|
ADesc.MaskLineEnd := rileByteBoundary;
|
|
ADesc.MaskBitOrder := riboBitsInOrder;
|
|
end;
|
|
|
|
// Palette
|
|
ADesc.PaletteColorCount:=0;
|
|
|
|
// Depth
|
|
if IsBitmap then
|
|
ADesc.Depth := 1
|
|
else
|
|
ADesc.Depth := 32;
|
|
|
|
if IsBitmap then
|
|
ADesc.ByteOrder := riboMSBFirst
|
|
else
|
|
ADesc.ByteOrder := riboLSBFirst;
|
|
|
|
ADesc.LineOrder := riloTopToBottom;
|
|
|
|
case ADesc.Depth of
|
|
0..8: ADesc.BitsPerPixel := ADesc.Depth;
|
|
9..16: ADesc.BitsPerPixel := 16;
|
|
17..32: ADesc.BitsPerPixel := 32;
|
|
else
|
|
ADesc.BitsPerPixel := 64;
|
|
end;
|
|
|
|
if IsBitmap then
|
|
begin
|
|
ADesc.LineEnd := rileByteBoundary;
|
|
ADesc.RedPrec := 1;
|
|
ADesc.RedShift := 0;
|
|
end else
|
|
begin
|
|
// Try retrieving the lineend
|
|
ADesc.LineEnd := rileDWordBoundary;
|
|
ADesc.MaskBitsPerPixel := 1;
|
|
ADesc.MaskShift := 0;
|
|
ADesc.MaskLineEnd := rileByteBoundary;
|
|
ADesc.MaskBitOrder := riboBitsInOrder;
|
|
end;
|
|
|
|
Result := True;
|
|
end;
|
|
|
|
function TMUIWidgetSet.RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): boolean;
|
|
begin
|
|
RawImage_QueryDescription([riqfRGB, riqfAlpha], ADesc);
|
|
ADesc.Width := TMuiBitmap(ABitmap).FWidth;
|
|
ADesc.Height := TMuiBitmap(ABitmap).FHeight;
|
|
|
|
{$ifdef VERBOSEAROS}
|
|
writeln('RawImage_DescriptionFromBitmap ', HexStr(Pointer(ABitmap)));
|
|
{$endif}
|
|
Result := True;
|
|
end;
|
|
|
|
function TMUIWidgetSet.RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean;
|
|
var
|
|
W, H: Integer;
|
|
MUICanvas: TMUICanvas absolute ADC;
|
|
begin
|
|
if Assigned(MUICanvas) then
|
|
begin
|
|
w := MUICanvas.DrawRect.Right;
|
|
h := MUICanvas.DrawRect.Bottom;
|
|
end else
|
|
begin
|
|
w := IntuitionBase^.ActiveScreen^.Width;
|
|
h := IntuitionBase^.ActiveScreen^.Height;
|
|
end;
|
|
{$ifdef VERBOSEAROS}
|
|
writeln('RawImage_DescriptionFromDevice ', HexStr(Pointer(ADC)));
|
|
{$endif}
|
|
ADesc.Width := w;
|
|
ADesc.Height := h;
|
|
RawImage_QueryDescription([riqfRGB], ADesc);
|
|
Result := True;
|
|
end;
|
|
|
|
function TMUIWidgetSet.RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean;
|
|
var
|
|
Bit: TMUIBitmap absolute ABitmap;
|
|
begin
|
|
ARawImage.Init;
|
|
{$ifdef VERBOSEAROS}
|
|
writeln('RawImage_FromBitmap');
|
|
{$endif}
|
|
if Assigned(Bit) then
|
|
begin
|
|
Bit.GetFromCanvas;
|
|
RawImage_QueryDescription([riqfUpdate,riqfRGB], ARawImage.Description);
|
|
ARawImage.Description.Width := Bit.FWidth;
|
|
ARawImage.Description.Height := Bit.FHeight;
|
|
ARawImage.Description.Depth := 32;
|
|
ARawImage.DataSize := Bit.FWidth * Bit.FHeight * SizeOf(LongWord);
|
|
ReAllocMem(ARawImage.Data, ARawImage.DataSize);
|
|
Move(Bit.FImage^, ARawImage.Data^, ARawImage.DataSize);
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function TMUIWidgetSet.RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean;
|
|
var
|
|
W, H: Integer;
|
|
MUICanvas: TMUICanvas absolute ADC;
|
|
T: AGraphics.TPoint;
|
|
begin
|
|
ARawImage.Init;
|
|
w := ARect.Right;
|
|
h := ARect.Bottom;
|
|
{$ifdef VERBOSEAROS}
|
|
writeln('RawImage_FromDevice ', w, ' x ', h);
|
|
{$endif}
|
|
ARawImage.Description.Width := w;
|
|
ARawImage.Description.Height := h;
|
|
RawImage_QueryDescription([riqfUpdate,riqfRGB], ARawImage.Description);
|
|
ARawImage.DataSize := w * h * SizeOf(LongWord);
|
|
ReAllocMem(ARawImage.Data, ARawImage.DataSize);
|
|
T := MUICanvas.GetOffset;
|
|
if Assigned(CyberGfxBase) then
|
|
Cybergraphics.ReadPixelArray(ARawImage.Data, 0, 0, w * SizeOf(LongWord), MUICanvas.RastPort, T.X, T.Y, w, h, RECTFMT_ARGB);
|
|
Result := True;
|
|
end;
|
|
|
|
function TMUIWidgetSet.RawImage_QueryDescription(AFlags: TRawImageQueryFlags; var ADesc: TRawImageDescription): Boolean;
|
|
begin
|
|
//writeln('QueryDescription');
|
|
//if riqfAlpha in AFlags then
|
|
begin
|
|
//always return rgba description
|
|
if not (riqfUpdate in AFlags) then
|
|
begin
|
|
//writeln('Init ', ADesc.Width);
|
|
ADesc.Init;
|
|
end;
|
|
|
|
ADesc.Format := ricfRGBA;
|
|
ADesc.Depth := 32;
|
|
ADesc.BitOrder := riboReversedBits;
|
|
ADesc.ByteOrder := riboLSBFirst;
|
|
ADesc.LineOrder := riloTopToBottom;
|
|
ADesc.LineEnd := rileDWordBoundary;
|
|
ADesc.BitsPerPixel := 32;
|
|
if ADesc.Width = 0 then
|
|
begin
|
|
ADesc.Width := cardinal(640);
|
|
ADesc.Height := cardinal(480);
|
|
end;
|
|
|
|
if riqfAlpha in AFlags then
|
|
ADesc.Depth := 32;
|
|
ADesc.AlphaPrec := 8;
|
|
ADesc.AlphaShift := 0;
|
|
|
|
if riqfMask in AFlags then
|
|
begin
|
|
//ADesc.MaskBitsPerPixel := 8;
|
|
//ADesc.MaskShift := 0;
|
|
//ADesc.MaskLineEnd := rileByteBoundary;
|
|
//ADesc.MaskBitOrder := riboBitsInOrder;
|
|
end;
|
|
|
|
if riqfRGB in AFlags
|
|
then begin
|
|
ADesc.RedPrec := 8;
|
|
ADesc.GreenPrec := 8;
|
|
ADesc.BluePrec := 8;
|
|
ADesc.RedShift := 8;
|
|
ADesc.GreenShift := 16;
|
|
ADesc.BlueShift := 24;
|
|
end;
|
|
|
|
|
|
{ADesc.AlphaPrec := 8;
|
|
ADesc.AlphaShift := 24;
|
|
|
|
if riqfRGB in AFlags
|
|
then begin
|
|
ADesc.RedPrec := 8;
|
|
ADesc.GreenPrec := 8;
|
|
ADesc.BluePrec := 8;
|
|
ADesc.RedShift := 16;
|
|
ADesc.GreenShift := 8;
|
|
ADesc.BlueShift := 0;
|
|
end;
|
|
}
|
|
AFlags := AFlags - [riqfRGB, riqfAlpha, riqfUpdate];
|
|
if AFlags = [] then Exit(True);
|
|
|
|
// continue with default
|
|
Include(AFlags, riqfUpdate);
|
|
end;
|
|
//Result := inherited RawImage_QueryDescription(AFlags, ADesc);
|
|
// reduce mem
|
|
//if Result and (ADesc.Depth = 24)
|
|
//then ADesc.BitsPerPixel := 24;
|
|
end;
|
|
|
|
function TMUIWidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor;
|
|
var
|
|
Canvas: TMUICanvas;
|
|
begin
|
|
Canvas := TMUICanvas(CanvasHandle);
|
|
if Assigned(Canvas) then
|
|
begin
|
|
Result := Canvas.GetPixel(X, Y);
|
|
end;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor);
|
|
var
|
|
Canvas: TMUICanvas;
|
|
begin
|
|
Canvas := TMUICanvas(CanvasHandle);
|
|
if Assigned(Canvas) then
|
|
begin
|
|
Canvas.SetPixel(X, Y, AColor);
|
|
end;
|
|
end;
|
|
|
|
function TMUIWidgetSet.CreateStandardCursor(ACursor: SmallInt): hCursor;
|
|
begin
|
|
Result := 1;
|
|
end;
|
|
|
|
constructor TMUIWidgetSet.Create;
|
|
begin
|
|
inherited Create;
|
|
MUIWidgetSet := self;
|
|
end;
|
|
|
|
destructor TMUIWidgetSet.Destroy;
|
|
begin
|
|
MUIWidgetSet := nil;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TMUIWidgetSet.CreateTimer(Interval: integer; TimerFunc: TWSTimerProc): TLCLHandle;
|
|
begin
|
|
Result := 0;
|
|
if Assigned(MUIApp) then
|
|
begin
|
|
Result := MUIApp.CreateTimer(Interval, TimerFunc);
|
|
end;
|
|
end;
|
|
|
|
function TMUIWidgetSet.DestroyTimer(TimerHandle: TLCLHandle): boolean;
|
|
begin
|
|
Result:=false;
|
|
if Assigned(MUIApp) then
|
|
begin
|
|
Result := MUIApp.DestroyTimer(TimerHandle);
|
|
end;
|
|
end;
|
|
|
|
procedure TMUIWidgetSet.DestroyLCLComponent(Sender: TObject);
|
|
begin
|
|
|
|
end;
|
|
|
|
|
|
Const
|
|
CLIP_PLAINTEXT = 2;
|
|
|
|
function TMUIWidgetSet.CreateThemeServices: TThemeServices;
|
|
begin
|
|
Result := TMUIThemeServices.Create;
|
|
end;
|
|
|
|
function TMUIWidgetSet.ClipboardFormatToMimeType(FormatID: TClipboardFormat): string;
|
|
begin
|
|
Result := '';
|
|
if FormatID = CLIP_PLAINTEXT then
|
|
Result := 'text/plain';
|
|
end;
|
|
|
|
function TMUIWidgetSet.ClipboardGetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat; Stream: TStream): boolean;
|
|
var
|
|
temp: string;
|
|
begin
|
|
Result := False;
|
|
if FormatID = CLIP_PLAINTEXT then
|
|
begin
|
|
Temp := GetTextFromClip(0);
|
|
Stream.Write(temp[1], Length(temp));
|
|
Result := True;
|
|
end;
|
|
end;
|
|
// ! ClipboardGetFormats: List will be created. You must free it yourself with FreeMem(List) !
|
|
function TMUIWidgetSet.ClipboardGetFormats(ClipboardType: TClipboardType; var Count: integer; var List: PClipboardFormat): boolean;
|
|
begin
|
|
Count := 1;
|
|
GetMem(List, SizeOf(TClipBoardFormat));
|
|
List^ := CLIP_PLAINTEXT;
|
|
Result := True;
|
|
end;
|
|
|
|
|
|
function TMUIWidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType; OnRequestProc: TClipboardRequestEvent; FormatCount: integer; Formats: PClipboardFormat): boolean;
|
|
var
|
|
DataStream: TStringStream;
|
|
Temp: string;
|
|
i: Integer;
|
|
begin
|
|
Result := True;
|
|
if (FormatCount = 0) or (OnRequestProc = nil) then
|
|
begin
|
|
end else
|
|
begin
|
|
DataStream := TStringStream.Create('');
|
|
DataStream.Size := 0;
|
|
DataStream.Position := 0;
|
|
For i := 0 to FormatCount - 1 do
|
|
begin
|
|
if Formats[i] <> CLIP_PLAINTEXT then
|
|
Continue;
|
|
OnRequestProc(Formats[i], DataStream);
|
|
if DataStream.Size > 0 then
|
|
begin
|
|
DataStream.Seek(0, soFromBeginning);
|
|
Temp := DataStream.ReadString(DataStream.Size - 1);
|
|
PutTextToClip(0, Temp);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TMUIWidgetSet.ClipboardRegisterFormat(const AMimeType: string): TClipboardFormat;
|
|
begin
|
|
Result := TClipboardFormat(-1);
|
|
if AMimeType = 'text/plain' then
|
|
Result := CLIP_PLAINTEXT;
|
|
end;
|
|
|
|
|
|
end.
|