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