1{
2 *****************************************************************************
3 *                                                                           *
4 *  This file is part of the Lazarus Component Library (LCL)                 *
5 *                                                                           *
6 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
7 *  for details about the copyright.                                         *
8 *                                                                           *
9 *  This program is distributed in the hope that it will be useful,          *
10 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
11 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
12 *                                                                           *
13 *****************************************************************************
14 }
15
16unit MUIInt;
17
18{$mode objfpc}{$H+}
19
20interface
21
22{$ifdef Trace}
23{$ASSERTIONS ON}
24{$endif}
25
26uses
27  // rtl+fcl
28  agraphics, Types, Classes, SysUtils, FPCAdds, Math,
29  // interfacebase
30  InterfaceBase,
31  // LCL
32  lclplatformdef, Dialogs, Controls, Forms, LCLStrConsts, LMessages, stdctrls,
33  LCLProc, LCLIntf, LCLType, GraphType, Graphics, Menus, Themes, muithemes,
34  // Amiga units
35  MUIBaseUnit, MUIFormsUnit, muidrawing, tagsparamshelper, muiglobal,
36  {$ifdef HASAMIGA}
37  exec, intuition, mui, utility, AmigaDos, icon,
38  cybergraphics,
39  inputevent, Cliputils,
40  {$endif}
41  // widgetset
42  WSLCLClasses, LCLMessageGlue;
43
44const
45  IdButtonTexts: array[idButtonOk..idButtonShield] of string = (
46 { idButtonOk       } 'OK',
47 { idButtonCancel   } 'Cancel',
48 { idButtonHelp     } 'Help',
49 { idButtonYes      } 'Yes',
50 { idButtonNo       } 'No',
51 { idButtonClose    } 'Close',
52 { idButtonAbort    } 'Abort',
53 { idButtonRetry    } 'Retry',
54 { idButtonIgnore   } 'Ignore',
55 { idButtonAll      } 'All',
56 { idButtonYesToAll } 'YesToAll',
57 { idButtonNoToAll  } 'NoToAll',
58 { idButtonOpen     } 'Open',
59 { idButtonSave     } 'Save',
60 { idButtonShield   } 'Shield'
61  );
62type
63  { TMUIWidgetSet }
64
65  TMUIWidgetSet = class(TWidgetSet)
66  protected
67    ThisAppDiskIcon: Pointer;
68    function CreateThemeServices: TThemeServices; override;
69    function GetAppHandle: THandle; override;
70  public
71    procedure PassCmdLineOptions; override;
72  public
73    function LCLPlatform: TLCLPlatform; override;
74    function GetLCLCapability(ACapability: TLCLCapability):PtrUInt; override;
75    // Application
76    procedure AppInit(var ScreenInfo: TScreenInfo); override;
77    procedure AppProcessMessages; override;
78    procedure AppWaitMessage; override;
79    procedure AppTerminate; override;
80    procedure AppMinimize; override;
81    procedure AppRestore; override;
82    procedure AppBringToFront; override;
83    procedure AppSetTitle(const ATitle: string); override;
84    function EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint; override;
85    //function MessageBox(hWnd: HWND; lpText: PChar; lpCaption: PChar;  uType: Cardinal): Integer; override;
86    function PromptUser(const DialogCaption: String; const DialogMessage: String; DialogType: LongInt; Buttons: PLongint; ButtonCount: LongInt; DefaultIndex: LongInt; EscapeResult: LongInt):LongInt; override;
87    function RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap: HBITMAP; out AMask: HBITMAP; ASkipMask: Boolean = false):Boolean; override;
88    function RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): boolean; override;
89    function RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean; override;
90    function RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean; override;
91    function RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean; override;
92    function RawImage_QueryDescription(AFlags: TRawImageQueryFlags; var ADesc: TRawImageDescription): Boolean; override;
93    function  DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override;
94    procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override;
95    function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
96    // Clipboard
97    function ClipboardFormatToMimeType(FormatID: TClipboardFormat): string; override;
98    function ClipboardGetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat; Stream: TStream): boolean; override;
99    // ! ClipboardGetFormats: List will be created. You must free it yourself with FreeMem(List) !
100    function ClipboardGetFormats(ClipboardType: TClipboardType; var Count: integer; var List: PClipboardFormat): boolean; override;
101    function ClipboardGetOwnerShip(ClipboardType: TClipboardType; OnRequestProc: TClipboardRequestEvent;  FormatCount: integer; Formats: PClipboardFormat): boolean; override;
102    function ClipboardRegisterFormat(const AMimeType: string): TClipboardFormat; override;
103
104  public
105    constructor Create; override;
106    destructor Destroy; override;
107
108    // debugging
109    procedure DebugOutEvent(Sender: TObject;s: string; var Handled: Boolean);
110    procedure DebugOutLNEvent(Sender: TObject;s: string; var Handled: Boolean);
111
112    // create and destroy
113    function CreateTimer(Interval: integer; TimerFunc: TWSTimerProc) : THandle; override;
114    function DestroyTimer(TimerHandle: THandle) : boolean; override;
115    procedure DestroyLCLComponent(Sender: TObject);virtual;
116
117    {$I muiwinapih.inc}
118  public
119  end;
120
121var
122  MUIWidgetSet: TMUIWidgetSet;
123  FocusWidget: Hwnd;
124implementation
125
126uses
127  MUIWSFactory, MUIWSForms, VInfo, muistdctrls, lazloggerbase;
128
129
130{$I muiwinapi.inc}
131
132{ TMUIWidgetSet }
133
134function TMUIWidgetSet.GetAppHandle: THandle;
135begin
136  Result := THandle(MUIApp);
137end;
138
139procedure TMUIWidgetSet.PassCmdLineOptions;
140begin
141  inherited PassCmdLineOptions;
142end;
143
144function TMUIWidgetSet.LCLPlatform: TLCLPlatform;
145begin
146  Result:=lpMUI;
147end;
148
149function TMUIWidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt;
150begin
151  case ACapability of
152    lcCanDrawOutsideOnPaint: Result := LCL_CAPABILITY_NO;
153    lcDragDockStartOnTitleClick: Result := LCL_CAPABILITY_NO;
154    lcNeedMininimizeAppWithMainForm: Result := LCL_CAPABILITY_NO;
155    lcAsyncProcess: Result := LCL_CAPABILITY_NO;
156    lcApplicationTitle: Result := LCL_CAPABILITY_YES;
157    lcApplicationWindow:Result := LCL_CAPABILITY_YES;
158    lcFormIcon: Result := LCL_CAPABILITY_NO;
159    lcModalWindow: Result := LCL_CAPABILITY_NO;
160    lcAntialiasingEnabledByDefault: Result := LCL_CAPABILITY_NO;
161    lcLMHelpSupport: Result := LCL_CAPABILITY_NO;
162    lcSendsUTF8KeyPress: Result := LCL_CAPABILITY_NO;
163  else
164    Result := inherited GetLCLCapability(ACapability);
165  end;
166end;
167
168var
169  // MUI does not copy this values, so we keep them here
170  AppTitle, FinalVers, Vers, CopyR, Comment, PrgName, Author: string;
171
172procedure TMUIWidgetSet.DebugOutEvent(Sender: TObject;s: string; var Handled: Boolean);
173begin
174  SysDebugln('(LCL:'+Sender.classname+'): '+ s);
175  Handled := True;
176end;
177
178procedure TMUIWidgetSet.DebugOutLNEvent(Sender: TObject;s: string; var Handled: Boolean);
179begin
180  SysDebugln('(LCL:'+Sender.classname+'): '+ s);
181  Handled := True;
182end;
183
184procedure TMUIWidgetSet.AppInit(var ScreenInfo: TScreenInfo);
185type
186  TVerArray = array[0..3] of Word;
187var
188  Info: TVersionInfo;
189  i,j: Integer;
190  TagList: TATagList;
191  Dollar: string;
192
193  function PV2Str(PV: TVerArray): String;
194   begin
195     Result := SysUtils.Format('%d.%d.%d.%d', [PV[0],PV[1],PV[2],PV[3]])
196   end;
197
198begin
199  // connect Debug log output
200  //DebugLogger.OnDbgOut := @DebugOutEvent;
201  //DebugLogger.OnDebugLn := @DebugOutLNEvent;
202  // Initial Application Values
203  Vers := '';
204  CopyR := '';
205  Comment := '';
206  Dollar := '$';
207  // Get the name from Application.Title, remove the Path Part
208  PrgName := ExtractFilename(Application.Title);
209  AppTitle := PrgName;
210  // Miu can't handle empty AppTitle, use Exename
211  if AppTitle = '' then
212    AppTitle := ExtractFilename(ParamStr(0));
213  // load Informations from resource
214  Info := TVersionInfo.Create;
215  try
216    Info.Load(HINSTANCE);
217    Vers := PV2Str(Info.FixedInfo.FileVersion);
218    for i := 0 to Info.StringFileInfo.Count - 1 do
219    begin
220      for j := 0 to Info.StringFileInfo.Items[i].Count - 1 do
221      begin
222        if Info.StringFileInfo.Items[i].Keys[j] = 'LegalCopyright' then
223          CopyR := Info.StringFileInfo.Items[i].Values[j]
224        else
225        if Info.StringFileInfo.Items[i].Keys[j] = 'Comments' then
226          Comment := Info.StringFileInfo.Items[i].Values[j]
227        else
228        if Info.StringFileInfo.Items[i].Keys[j] = 'CompanyName' then
229          Author := Info.StringFileInfo.Items[i].Values[j]
230        else
231        if Info.StringFileInfo.Items[i].Keys[j] = 'ProductName' then
232        begin
233          if Length(Trim(Info.StringFileInfo.Items[i].Values[j])) > 0  then
234            PrgName := Info.StringFileInfo.Items[i].Values[j];
235        end;
236      end;
237    end;
238  except
239  end;
240  // end resource loading
241  Info.Free;
242  // get the Icon (to use as Iconify Image), nil is no problem, MUI handle that and use the default
243  ThisAppDiskIcon := GetDiskObject(PChar(ParamStr(0)));
244  // Version information as Standard AMIGA Version string
245  FinalVers := Dollar + 'VER: ' + PrgName + ' ' + Vers + '('+{$I %DATE%}+')';
246  // Create the Application
247  TagList.AddTags([
248    NativeInt(MUIA_Application_Base), NativeUInt(PChar(AppTitle)),
249    MUIA_Application_DiskObject, NativeUInt(ThisAppDiskIcon),
250    MUIA_Application_Title, NativeUInt(PChar(AppTitle)),
251    MUIA_Application_Version, NativeUInt(PChar(FinalVers)),
252    MUIA_Application_Copyright, NativeUInt(PChar(CopyR)),
253    MUIA_Application_Description, NativeUInt(PChar(Comment)),
254    MUIA_Application_Author, NativeUInt(PChar(Author))
255    ]);
256  MUIApp := TMuiApplication.Create(TagList);
257  if not Assigned(MUIApp) or not Assigned(MUIApp.Obj) then
258    raise EInvalidOperation.Create('Unable to Create Application object.');
259  // same basic Screen info, no idea where to get that
260  ScreenInfo.PixelsPerInchX := 72;
261  ScreenInfo.PixelsPerInchY := 72;
262  ScreenInfo.ColorDepth := 32;
263end;
264
265procedure TMUIWidgetSet.AppProcessMessages;
266begin;
267  MuiApp.ProcessMessages;
268end;
269
270procedure TMUIWidgetSet.AppWaitMessage;
271begin
272  MuiApp.WaitMessages;
273end;
274
275procedure TMUIWidgetSet.AppTerminate;
276begin
277  FreeDiskObject(ThisAppDiskIcon);
278end;
279
280procedure TMUIWidgetSet.AppMinimize;
281begin
282  MuiApp.Iconified := True;
283end;
284
285procedure TMUIWidgetSet.AppRestore;
286begin
287  MuiApp.Iconified := False;
288end;
289
290procedure TMUIWidgetSet.AppBringToFront;
291begin
292
293end;
294
295procedure TMUIWidgetSet.AppSetTitle(const ATitle: string);
296begin
297
298end;
299
300function TMUIWidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont;
301  Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint;
302begin
303  Result:=0;
304end;
305
306(*
307function TMUIWidgetSet.MessageBox(hWnd: HWND; lpText: PChar; lpCaption: PChar;
308  uType: Cardinal): Integer;
309begin
310end;*)
311
312function TMUIWidgetSet.PromptUser(const DialogCaption: String;
313  const DialogMessage: String; DialogType: LongInt; Buttons: PLongint;
314  ButtonCount: LongInt; DefaultIndex: LongInt; EscapeResult: LongInt): LongInt;
315var
316  ES: PEasyStruct;
317  BtnText: string;
318  Res: LongInt;
319  BtnIdx : LongInt;
320  BtnId: LongInt;
321begin
322  New(ES);
323  ES^.es_StructSize := SizeOf(TEasyStruct);
324  ES^.es_Flags := 0;
325  ES^.es_Title := PChar(DialogCaption);
326  ES^.es_TextFormat := PChar(DialogMessage);
327  for BtnIdx := 0 to ButtonCount-1 do
328  begin
329    BtnID := Buttons[BtnIdx];
330    if (BtnID >= Low(IdButtonTexts)) and (BtnID <= High(IdButtonTexts)) then
331    begin
332      if BtnIdx = 0 then
333        BtnText := IdButtonTexts[BtnID]
334      else
335        BtnText := BtnText + '|'+ IdButtonTexts[BtnID];
336    end else
337    begin
338      if BtnIdx = 0 then
339        BtnText := IntToStr(BtnID)
340      else
341        BtnText := BtnText + '|'+ IntToStr(BtnID);
342    end;
343  end;
344  ES^.es_GadgetFormat := PChar(BtnText);
345  {$ifdef MorphOS}
346  // App after MUI_RequestA is blocked
347  Res := EasyRequestArgs(nil, ES, nil, nil);
348  {$else}
349  Res := MUI_RequestA(MuiApp.Obj, MuiApp.MainWin, 0, ES^.es_Title, ES^.es_GadgetFormat, ES^.es_TextFormat, nil);
350  {$endif}
351  Result := EscapeResult;
352  Res := Res - 1;
353  if Res < 0 then
354    Res := ButtonCount - 1;
355  if (Res >= 0) and (Res < ButtonCount) then
356    Result := Buttons[Res];
357  Dispose(ES);
358end;
359
360type
361  TARGBPixel = packed record
362    A: Byte;
363    R: Byte;
364    G: Byte;
365    B: Byte;
366  end;
367  PARGBPixel = ^TARGBPixel;
368
369  {TABGRPixel = packed record
370    R: Byte;
371    G: Byte;
372    B: Byte;
373    A: Byte;
374  end;}
375  TABGRPixel = array[0..3] of Byte;
376  PABGRPixel = ^TABGRPixel;
377
378{.$define VERBOSEAROS}
379
380function TMUIWidgetSet.RawImage_CreateBitmaps(const ARawImage: TRawImage; out
381  ABitmap: HBITMAP; out AMask: HBITMAP; ASkipMask: Boolean): Boolean;
382var
383  Bit: TMUIBitmap;
384  //Ridx, GIdx, BIdx, AIdx: Byte;
385begin
386  {$ifdef VERBOSEAROS}
387  writeln('RawImage_CreateBitmaps ' + IntToStr(ARawImage.Description.Width) + ' x ' + IntToStr(ARawImage.Description.Height) + ' - ' + IntToStr(ARawImage.Description.Depth) + ' = ' + IntToStr(ARawImage.DataSize));
388  {$endif}
389  Bit := TMUIBitmap.Create(ARawImage.Description.Width, ARawImage.Description.Height, ARawImage.Description.Depth);
390  //ARawImage.Description.GetRGBIndices(Ridx, GIdx, BIdx, AIdx);
391  //writeln('R: ',Ridx, ' G: ', GIdx, ' B: ', BIdx, ' A: ', AIdx);
392  if ARawImage.DataSize > 0 then
393    Move(ARawImage.Data^, Bit.FImage^, ARawImage.DataSize);
394  //PLongWord(Bit.FImage)^ := $FFFFFFFF;
395  ABitmap := HBITMAP(Bit);
396  AMask := 0;
397  Result := True;
398  //writeln('created Bitmap: ', HexStr(Bit), ' width: ', Bit.FWidth, ' ??? ', ARawImage.Description.Width, ' Datasize: ', ARawImage.DataSize);
399  //writeln(' create image: ', ARawImage.Description.Width,'x', ARawImage.Description.Height,' : ',ARawImage.Description.Depth, ' - ', ARawImage.DataSize, ' $', HexStr(Bit));
400  //writeln('   Desc: ', HexStr(@(ARawImage.Description)));
401end;
402
403function RawImage_DescriptionFromDrawable(out
404  ADesc: TRawImageDescription; ACustomAlpha: Boolean
405  ): boolean;
406var
407  IsBitmap: Boolean;
408begin
409  {$ifdef VERBOSEAROS}
410  writeln('RawImage_DescriptionFromDrawable');
411  {$endif}
412  //writeln('GetDescription from Drawable');
413  IsBitMap := False;
414
415  ADesc.Init;
416  ADesc.Width := cardinal(0);
417  ADesc.Height := cardinal(0);
418  ADesc.BitOrder := riboBitsInOrder;
419  ADesc.PaletteColorCount := 0;
420  if ACustomAlpha then
421  begin
422    // always give pixbuf description for alpha images
423    ADesc.Format:=ricfRGBA;
424    ADesc.Depth := 32;
425    ADesc.BitsPerPixel := 32;
426    ADesc.LineEnd := rileDWordBoundary;
427    ADesc.ByteOrder := riboLSBFirst;
428
429    ADesc.RedPrec := 8;
430    ADesc.RedShift := 0;
431    ADesc.GreenPrec := 8;
432    ADesc.GreenShift := 8;
433    ADesc.BluePrec := 8;
434    ADesc.BlueShift := 16;
435    ADesc.AlphaPrec := 8;
436    ADesc.AlphaShift := 24;
437
438    ADesc.MaskBitsPerPixel := 1;
439    ADesc.MaskShift := 0;
440    ADesc.MaskLineEnd := rileByteBoundary;
441    ADesc.MaskBitOrder := riboBitsInOrder;
442
443    Exit(True);
444  end;
445
446  // Format
447  if IsBitmap then
448  begin
449    ADesc.Format := ricfGray;
450  end else
451  begin
452    ADesc.Format:=ricfRGBA;
453    ADesc.RedPrec := 8;
454    ADesc.RedShift := 0;
455    ADesc.GreenPrec := 8;
456    ADesc.GreenShift := 8;
457    ADesc.BluePrec := 8;
458    ADesc.BlueShift := 16;
459    ADesc.AlphaPrec := 8;
460    ADesc.AlphaShift := 24;
461
462    ADesc.MaskBitsPerPixel := 1;
463    ADesc.MaskShift := 0;
464    ADesc.MaskLineEnd := rileByteBoundary;
465    ADesc.MaskBitOrder := riboBitsInOrder;
466  end;
467
468  // Palette
469  ADesc.PaletteColorCount:=0;
470
471  // Depth
472  if IsBitmap then
473    ADesc.Depth := 1
474  else
475    ADesc.Depth := 32;
476
477  if IsBitmap then
478    ADesc.ByteOrder := riboMSBFirst
479  else
480    ADesc.ByteOrder := riboLSBFirst;
481
482  ADesc.LineOrder := riloTopToBottom;
483
484  case ADesc.Depth of
485    0..8:   ADesc.BitsPerPixel := ADesc.Depth;
486    9..16:  ADesc.BitsPerPixel := 16;
487    17..32: ADesc.BitsPerPixel := 32;
488  else
489    ADesc.BitsPerPixel := 64;
490  end;
491
492  if IsBitmap then
493  begin
494    ADesc.LineEnd  := rileByteBoundary;
495    ADesc.RedPrec  := 1;
496    ADesc.RedShift := 0;
497  end else
498  begin
499    // Try retrieving the lineend
500    ADesc.LineEnd := rileDWordBoundary;
501    ADesc.MaskBitsPerPixel := 1;
502    ADesc.MaskShift := 0;
503    ADesc.MaskLineEnd := rileByteBoundary;
504    ADesc.MaskBitOrder := riboBitsInOrder;
505  end;
506
507  Result := True;
508end;
509
510function TMUIWidgetSet.RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): boolean;
511begin
512  RawImage_QueryDescription([riqfRGB, riqfAlpha], ADesc);
513  ADesc.Width := TMuiBitmap(ABitmap).FWidth;
514  ADesc.Height := TMuiBitmap(ABitmap).FHeight;
515
516  {$ifdef VERBOSEAROS}
517  writeln('RawImage_DescriptionFromBitmap ', HexStr(Pointer(ABitmap)));
518  {$endif}
519  Result := True;
520end;
521
522function TMUIWidgetSet.RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean;
523var
524  W, H: Integer;
525  MUICanvas: TMUICanvas absolute ADC;
526begin
527  if Assigned(MUICanvas) then
528  begin
529    w := MUICanvas.DrawRect.Right;
530    h := MUICanvas.DrawRect.Bottom;
531  end else
532  begin
533    w := IntuitionBase^.ActiveScreen^.Width;
534    h := IntuitionBase^.ActiveScreen^.Height;
535  end;
536  {$ifdef VERBOSEAROS}
537  writeln('RawImage_DescriptionFromDevice ', HexStr(Pointer(ADC)));
538  {$endif}
539  ADesc.Width := w;
540  ADesc.Height := h;
541  RawImage_QueryDescription([riqfRGB], ADesc);
542  Result := True;
543end;
544
545function TMUIWidgetSet.RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean;
546var
547  Bit: TMUIBitmap absolute ABitmap;
548begin
549  ARawImage.Init;
550  {$ifdef VERBOSEAROS}
551  writeln('RawImage_FromBitmap');
552  {$endif}
553  if Assigned(Bit) then
554  begin
555    Bit.GetFromCanvas;
556    RawImage_QueryDescription([riqfUpdate,riqfRGB], ARawImage.Description);
557    ARawImage.Description.Width := Bit.FWidth;
558    ARawImage.Description.Height := Bit.FHeight;
559    ARawImage.Description.Depth := 32;
560    ARawImage.DataSize := Bit.FWidth * Bit.FHeight * SizeOf(LongWord);
561    ReAllocMem(ARawImage.Data, ARawImage.DataSize);
562    Move(Bit.FImage^, ARawImage.Data^, ARawImage.DataSize);
563  end;
564  Result := True;
565end;
566
567function TMUIWidgetSet.RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean;
568var
569  W, H: Integer;
570  MUICanvas: TMUICanvas absolute ADC;
571  T: AGraphics.TPoint;
572begin
573  ARawImage.Init;
574  w := ARect.Right;
575  h := ARect.Bottom;
576  {$ifdef VERBOSEAROS}
577  writeln('RawImage_FromDevice ', w, ' x ', h);
578  {$endif}
579  ARawImage.Description.Width := w;
580  ARawImage.Description.Height := h;
581  RawImage_QueryDescription([riqfUpdate,riqfRGB], ARawImage.Description);
582  ARawImage.DataSize := w * h * SizeOf(LongWord);
583  ReAllocMem(ARawImage.Data, ARawImage.DataSize);
584  T := MUICanvas.GetOffset;
585  if Assigned(CyberGfxBase) then
586    Cybergraphics.ReadPixelArray(ARawImage.Data, 0, 0, w * SizeOf(LongWord), MUICanvas.RastPort, T.X, T.Y, w, h, RECTFMT_ARGB);
587  Result := True;
588end;
589
590function TMUIWidgetSet.RawImage_QueryDescription(AFlags: TRawImageQueryFlags; var ADesc: TRawImageDescription): Boolean;
591begin
592  //writeln('QueryDescription');
593  //if riqfAlpha in AFlags then
594  begin
595    //always return rgba description
596    if not (riqfUpdate in AFlags)  then
597    begin
598      //writeln('Init ', ADesc.Width);
599      ADesc.Init;
600    end;
601
602    ADesc.Format := ricfRGBA;
603    ADesc.Depth := 32;
604    ADesc.BitOrder := riboReversedBits;
605    ADesc.ByteOrder := riboLSBFirst;
606    ADesc.LineOrder := riloTopToBottom;
607    ADesc.LineEnd := rileDWordBoundary;
608    ADesc.BitsPerPixel := 32;
609    if ADesc.Width = 0 then
610    begin
611      ADesc.Width := cardinal(640);
612      ADesc.Height := cardinal(480);
613    end;
614
615    if riqfAlpha in AFlags then
616      ADesc.Depth := 32;
617    ADesc.AlphaPrec := 8;
618    ADesc.AlphaShift := 0;
619
620    if riqfMask in AFlags then
621    begin
622      //ADesc.MaskBitsPerPixel := 8;
623      //ADesc.MaskShift := 0;
624      //ADesc.MaskLineEnd := rileByteBoundary;
625      //ADesc.MaskBitOrder := riboBitsInOrder;
626    end;
627
628    if riqfRGB in AFlags
629    then begin
630      ADesc.RedPrec := 8;
631      ADesc.GreenPrec := 8;
632      ADesc.BluePrec := 8;
633      ADesc.RedShift := 8;
634      ADesc.GreenShift := 16;
635      ADesc.BlueShift := 24;
636    end;
637
638
639    {ADesc.AlphaPrec := 8;
640    ADesc.AlphaShift := 24;
641
642    if riqfRGB in AFlags
643    then begin
644      ADesc.RedPrec := 8;
645      ADesc.GreenPrec := 8;
646      ADesc.BluePrec := 8;
647      ADesc.RedShift := 16;
648      ADesc.GreenShift := 8;
649      ADesc.BlueShift := 0;
650    end;
651    }
652    AFlags := AFlags - [riqfRGB, riqfAlpha, riqfUpdate];
653    if AFlags = [] then Exit(True);
654
655    // continue with default
656    Include(AFlags, riqfUpdate);
657  end;
658  //Result := inherited RawImage_QueryDescription(AFlags, ADesc);
659  // reduce mem
660  //if Result and (ADesc.Depth = 24)
661  //then ADesc.BitsPerPixel := 24;
662end;
663
664function TMUIWidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor;
665var
666  Canvas: TMUICanvas;
667begin
668  Canvas := TMUICanvas(CanvasHandle);
669  if Assigned(Canvas) then
670  begin
671    Result := Canvas.GetPixel(X, Y);
672  end;
673end;
674
675procedure TMUIWidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor);
676var
677  Canvas: TMUICanvas;
678begin
679  Canvas := TMUICanvas(CanvasHandle);
680  if Assigned(Canvas) then
681  begin
682    Canvas.SetPixel(X, Y, AColor);
683  end;
684end;
685
686function TMUIWidgetSet.CreateStandardCursor(ACursor: SmallInt): hCursor;
687begin
688  Result := 1;
689end;
690
691constructor TMUIWidgetSet.Create;
692begin
693  inherited Create;
694  MUIWidgetSet := self;
695end;
696
697destructor TMUIWidgetSet.Destroy;
698begin
699  MUIWidgetSet := nil;
700  inherited Destroy;
701end;
702
703function TMUIWidgetSet.CreateTimer(Interval: integer; TimerFunc: TWSTimerProc): THandle;
704begin
705  Result := 0;
706  if Assigned(MUIApp) then
707  begin
708    Result := MUIApp.CreateTimer(Interval, TimerFunc);
709  end;
710end;
711
712function TMUIWidgetSet.DestroyTimer(TimerHandle: THandle): boolean;
713begin
714  Result:=false;
715  if Assigned(MUIApp) then
716  begin
717    Result := MUIApp.DestroyTimer(TimerHandle);
718  end;
719end;
720
721procedure TMUIWidgetSet.DestroyLCLComponent(Sender: TObject);
722begin
723
724end;
725
726
727Const
728  CLIP_PLAINTEXT = 2;
729
730function TMUIWidgetSet.CreateThemeServices: TThemeServices;
731begin
732  Result := TMUIThemeServices.Create;
733end;
734
735function TMUIWidgetSet.ClipboardFormatToMimeType(FormatID: TClipboardFormat): string;
736begin
737  Result := '';
738  if FormatID = CLIP_PLAINTEXT then
739    Result := 'text/plain';
740end;
741
742function TMUIWidgetSet.ClipboardGetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat; Stream: TStream): boolean;
743var
744  temp: string;
745begin
746  Result := False;
747  if FormatID = CLIP_PLAINTEXT then
748  begin
749    Temp := GetTextFromClip(0);
750    Stream.Write(temp[1], Length(temp));
751    Result := True;
752  end;
753end;
754    // ! ClipboardGetFormats: List will be created. You must free it yourself with FreeMem(List) !
755function TMUIWidgetSet.ClipboardGetFormats(ClipboardType: TClipboardType; var Count: integer; var List: PClipboardFormat): boolean;
756begin
757  Count := 1;
758  GetMem(List, SizeOf(TClipBoardFormat));
759  List^ := CLIP_PLAINTEXT;
760  Result := True;
761end;
762
763
764function TMUIWidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType; OnRequestProc: TClipboardRequestEvent;  FormatCount: integer; Formats: PClipboardFormat): boolean;
765var
766  DataStream: TStringStream;
767  Temp: string;
768  i: Integer;
769begin
770  Result := True;
771  if (FormatCount = 0) or (OnRequestProc = nil) then
772  begin
773  end else
774  begin
775    DataStream := TStringStream.Create('');
776    DataStream.Size := 0;
777    DataStream.Position := 0;
778    For i := 0 to FormatCount - 1 do
779    begin
780      if Formats[i] <> CLIP_PLAINTEXT then
781        Continue;
782      OnRequestProc(Formats[i], DataStream);
783      if DataStream.Size > 0 then
784      begin
785        DataStream.Seek(0, soFromBeginning);
786        Temp := DataStream.ReadString(DataStream.Size - 1);
787        PutTextToClip(0, Temp);
788      end;
789    end;
790  end;
791end;
792
793
794function TMUIWidgetSet.ClipboardRegisterFormat(const AMimeType: string): TClipboardFormat;
795begin
796  Result := TClipboardFormat(-1);
797  if AMimeType = 'text/plain' then
798    Result := CLIP_PLAINTEXT;
799end;
800
801
802end.
803