svclutils.pas

Alpha Controls.v5.46b Source

unit sVclUtils;
{$I sDefs.inc}
{.$DEFINE LOGGED}

interface

uses
  Classes, Controls, SysUtils, StdCtrls, windows,
  Dialogs, Graphics, Forms, Messages, extctrls, //sScrollBar,
  comctrls, sConst, Menus, inifiles, registry, acntUtils, sCommonData,
{$IFNDEF ALITE}
  sEdit, sMemo, sComboBox, sToolEdit, sCurrEdit, sDateUtils,
  sCustomComboEdit, sRadioButton, sMonthCalendar,
{$ENDIF}
  {$IFDEF USEDB}db, dbgrids, dbCtrls, {$ENDIF}
  sCheckBox, sGraphUtils, buttons{$IFDEF LOGGED}, sDebugMsgs{$ENDIF};

const
  AlignToInt: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);

function LeftToRight(Control : TControl; NormalAlignment : boolean = True) : boolean;
procedure AddToAdapter(Frame : TWinControl);
//procedure RemoveFromAdapter(Frame : TWinControl);
procedure BroadCastMsg(Ctrl : hwnd; Message : TMessage);

procedure SkinPaintTo(Bmp : TBitmap; Ctrl : TControl; Left : integer = 0; Top : integer = 0);
procedure PrepareForAnimation(Ctrl : TWinControl);
procedure AnimShowControl(Ctrl : TWinControl; wTime : word = 0);

function WorkRect : TRect;
procedure SetParentUpdated(wc : TWinControl); overload;
procedure SetParentUpdated(pHwnd : hwnd); overload
procedure InitParentColor(Control : TWinControl);

procedure PaintControls(DC: HDC; OwnerControl : TWinControl; ChangeCache : boolean; Offset : TPoint; AHandle : THandle = 0);

function SendAMessage(Handle : hwnd; Cmd : Integer; LParam : longword = 0) : longint; overload; // may be removed later
function SendAMessage(Control : TControl; Cmd : Integer; LParam : longword = 0) : longint; overload;
procedure SetBoolMsg(Handle : hwnd; Cmd : Cardinal; Value : boolean);
function GetBoolMsg(Control : TWinControl; Cmd : Cardinal) : boolean; overload;
function GetBoolMsg(CtrlHandle : hwnd; Cmd : Cardinal) : boolean; overload;
procedure RepaintShadows(Control : TWinControl; BGBmp : graphics.TBitmap);
procedure RepaintsGraphicControls(WinControl : TWinControl);
function ControlIsReady(Control : TControl) : boolean;
function GetOwnerForm(Component: TComponent) : TCustomForm;
function GetOwnerFrame(Component: TComponent) : TCustomFrame;
procedure SetPanelFocus(Panel : TWinControl);
procedure SetControlsEnabled(Parent:TWinControl; Value: boolean);
function CheckPanelFilled(Panel:TCustomPanel):boolean;
{$IFDEF USEDB}
procedure ComboBoxFilling(ComboBox:TComboBox; DataSet:TDataSet; const CodeField, NameField:string; CountSymb:integer; FromDOSToWIN: boolean);
procedure FillsComboBox(sC : TCustomComboBox; CharsInCode: smallint; sD: TDataSet);
{$ENDIF}
function GetStringFlags(Control: TControl; al: TAlignment): longint;
procedure RepaintsControls(Owner: TWinControl; BGChanged : boolean);
function GetControlByName(ParentControl : TWinControl; const CtrlName : string) : TControl;
procedure AlphaBroadCast(Control : TWinControl; var Message);
procedure SendToProvider(Form : TCustomform; var Message);
function GetCtrlRange(Ctl : TWinControl; nBar : integer) : integer;
function ACClientRect(Handle : hwnd): TRect;
function GetAlignShift(Ctrl : TWinControl; Align : TAlign; GraphCtrlsToo : boolean = False) : integer;

type
  TOutputWindow = class(TCustomControl)
  private
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    property Canvas;
  end;

var
  ow : TOutPutwindow = nil;
  acPrintDC : hdc = 0;
  acSrcBmp : TBitmap = nil;
//  acDstBmp : TBitmap;

  uxthemeLib : Cardinal;
  Ac_SetWindowTheme : function(hwnd: HWND; pszSubAppName: LPCWSTR; pszSubIdList: LPCWSTR): HRESULT; stdcall;

implementation

uses
  {$IFNDEF ALITE} sStatusBar, sPageControl, sSpinEdit, sGroupBox, sGauge, sSkinProvider,
  sScrollBox, sComboBoxes, sSplitter,{$ENDIF} sPanel, sStyleSimply,
  sMessages, sMaskData, math, ShellAPI, sSkinManager{$IFDEF DEVEX}, cxGrid{$ENDIF};

function LeftToRight(Control : TControl; NormalAlignment : boolean = True) : boolean;
begin
  if NormalAlignment
    then Result := (Control.BidiMode = bdLeftToRight) or not SysLocale.MiddleEast
    else Result := (Control.BidiMode <> bdLeftToRight) and SysLocale.MiddleEast;
end;

procedure AddToAdapter(Frame : TWinControl);
var
  c : TWinControl;
begin
  if (csDesigning in Frame.ComponentState) then Exit;
  c := GetParentForm(Frame);
  if c <> nil then SendMessage(c.Handle, SM_ALPHACMD, MakeWParam(0, AC_CONTROLLOADED), longword(Frame));
end;

procedure BroadCastMsg(Ctrl : hwnd; Message : TMessage);
var
  hCtrl : THandle;
begin
  hCtrl := GetTopWindow(Ctrl);
  while hCtrl <> 0 do begin
    if (GetWindowLong(hCtrl, GWL_STYLE) and WS_CHILD) = WS_CHILD then SendMessage(hCtrl, Message.Msg, Message.WParam, Message.LParam);
    hCtrl := GetNextWindow(hCtrl, GW_HWNDNEXT);
  end;
end;

procedure SkinPaintTo(Bmp : TBitmap; Ctrl : TControl; Left : integer = 0; Top : integer = 0);
var
  I: Integer;
  SaveIndex : hdc;
  cR : TRect;
  DC : hdc;
begin
  if not Ctrl.Visible then Exit;
  GetWindowRect(TWinControl(Ctrl).Handle, cR);
  DC := Bmp.Canvas.Handle;
  IntersectClipRect(DC, 0, 0, Ctrl.Width, Ctrl.Height);
  if Ctrl is TWinControl then begin

    if (Ctrl is TForm) and (TForm(Ctrl).FormStyle = fsMDIForm) then for I := 0 to TForm(Ctrl).MDIChildCount - 1 do begin
      SaveIndex := SaveDC(DC);
      MoveWindowOrg(DC, TForm(Ctrl).MDIChildren[i].Left, TForm(Ctrl).MDIChildren[i].Top);
      SkinPaintTo(Bmp, TForm(Ctrl).MDIChildren[i], TForm(Ctrl).MDIChildren[i].Left, TForm(Ctrl).MDIChildren[i].Top);
      RestoreDC(DC, SaveIndex);
    end;

    if (Ctrl is TTabsheet) and (TTabSheet(Ctrl).BorderWidth <> 0) then begin
      MoveWindowOrg(DC, TTabSheet(Ctrl).BorderWidth, TTabSheet(Ctrl).BorderWidth);
    end;

    if GetBoolMsg(TWinControl(Ctrl), AC_CTRLHANDLED)
      then SendMessage(TWinControl(Ctrl).Handle, WM_PRINT, longint(DC), 0)
      else TWinControl(Ctrl).PaintTo(DC, 0, 0);

    for I := 0 to TWinControl(Ctrl).ControlCount - 1 do if (TWinControl(Ctrl).Controls[I] is TWinControl) and TWinControl(Ctrl).Controls[I].Visible then begin
      SaveIndex := SaveDC(DC);
      if not (TWinControl(Ctrl).Controls[I] is TCustomForm) or (TWinControl(Ctrl).Controls[I].Parent <> nil) then begin
        MoveWindowOrg(DC, TWinControl(Ctrl).Controls[I].Left, TWinControl(Ctrl).Controls[I].Top);
      end;
      SkinPaintTo(Bmp, TWinControl(Ctrl).Controls[I], TWinControl(Ctrl).Controls[I].Left, TWinControl(Ctrl).Controls[I].Top);
      RestoreDC(DC, SaveIndex);
    end;

    if (Ctrl is TTabsheet) and (TTabSheet(Ctrl).BorderWidth <> 0) then begin
      MoveWindowOrg(DC, -TTabSheet(Ctrl).BorderWidth, -TTabSheet(Ctrl).BorderWidth);
    end;
  end
  else Ctrl.Perform(WM_PRINT, longint(DC), 0);
end;

type
  TacWinControl = class(TWinControl);

procedure SetChildOrderAfter(Child: TWinControl; Control: TControl);
var
  i: Integer;
begin
  for i := 0 to Child.Parent.ControlCount do if Child.Parent.Controls[i] = Control then begin
    TacWinControl(Child.Parent).SetChildOrder(Child, i + 1);
    break;
  end;
end;

procedure PrepareForAnimation(Ctrl : TWinControl);
var
  Flags : dword;
  R : TRect;
  ScrDC : hdc;
begin
  GetWindowRect(Ctrl.Handle, R);
  if acSrcBmp = nil then begin
    acSrcBmp := CreateBmp24(Ctrl.width, Ctrl.Height);
    ScrDC := GetWindowDC(0);
    BitBlt(acSrcBmp.Canvas.Handle, 0, 0, Ctrl.width, Ctrl.Height, ScrDC, R.Left, R.Top, SRCCOPY);
    ReleaseDC(Ctrl.Handle, ScrDC);
  end;

  if ow = nil then ow := TOutPutWindow.Create(Ctrl);
  if Ctrl.Parent <> nil then begin
    ow.Parent := Ctrl.Parent;
    if ow = nil then Exit;
    SetChildOrderAfter(ow, Ctrl);
    ow.BoundsRect := Ctrl.BoundsRect;
  end
  else begin
    ow.BoundsRect := R;
  end;
  if ow.Parent = nil then begin
    Flags := SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE;
    SetWindowPos(ow.Handle, GetWindow(TWinControl(Ctrl).Handle, GW_HWNDPREV), 0, 0, 0, 0, Flags);
  end
  else ShowWindow(ow.Handle, SW_SHOWNA);
end;

procedure AnimShowControl(Ctrl : TWinControl; wTime : word = 0);
const
  DelayValue = 8;
var
  NewBmp : TBitmap;
  DC : hdc;
  i, StepCount : integer;
  Percent, p : integer;
  sp : longint;
  acDstBmp : TBitmap;
begin
  if ow = nil then PrepareForAnimation(Ctrl);
  if ow = nil then Exit;

  acDstBmp := CreateBmp24(Ctrl.width, Ctrl.Height);

  acDstBmp.Canvas.Lock;
  acPrintDC := acDstBmp.Canvas.Handle;
  SkinPaintTo(acDstBmp, Ctrl);
  if acDstBmp = nil then Exit;
  acPrintDC := 0;
  acDstBmp.Canvas.UnLock;

  NewBmp := CreateBmp32(Ctrl.width, Ctrl.Height);
  StepCount := wTime div DelayValue;

  if Ctrl is TCustomForm then sp := SendMessage(Ctrl.Handle, SM_ALPHACMD, MakeWParam(0, AC_GETPROVIDER), 0) else sp := 0;
  if (sp <> 0) then begin
    FillArOR(TsSkinProvider(sp));
    if ow = nil then Exit;
    SetWindowRgn(ow.Handle, GetRgnFromArOR(TsSkinProvider(sp)), False);
  end;
  DC := GetWindowDC(ow.Handle);

  if StepCount > 0 then begin
    p := 255 div StepCount;
    Percent := 255;
    i := 0;
    while i <= StepCount do begin
      SumBitmapsByMask(NewBmp, acSrcBmp, acDstBmp, nil, max(0, Percent));
      BitBlt(DC, 0, 0, Ctrl.Width, Ctrl.Height, NewBmp.Canvas.Handle, 0, 0, SRCCOPY);
      if Assigned(acMagnForm) then SendMessage(acMagnForm.Handle, SM_ALPHACMD, MakeWParam(0, AC_REFRESH), 0);
      inc(i);
      dec(Percent, p);
      if (i > StepCount) then Break;
      if StepCount > 0 then Sleep(DelayValue);
    end;
  end;
  BitBlt(DC, 0, 0, Ctrl.width, Ctrl.Height, acDstBmp.Canvas.Handle, 0, 0, SRCCOPY);

  if Assigned(acMagnForm) then SendMessage(acMagnForm.Handle, SM_ALPHACMD, MakeWParam(0, AC_REFRESH), 0);
  if not (Ctrl is TCustomForm) or (DWord(GetWindowLong(Ctrl.Handle, GWL_EXSTYLE)) and $00080000 <> $00080000) 
    then SetWindowPos(ow.Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOCOPYBITS or SWP_NOACTIVATE);
  ReleaseDC(ow.Handle, DC);
  FreeAndnil(ow);
  FreeAndNil(NewBmp);
  RedrawWindow(Ctrl.Handle, nil, 0, RDW_ALLCHILDREN or RDW_INVALIDATE or RDW_UPDATENOW);
  FreeAndNil(acSrcBmp);
  FreeAndNil(acDstBmp);
end;

procedure SetParentUpdated(wc : TWinControl); overload;
var
  i : integer;
begin
  try
    i := 0;
    while i < wc.ControlCount do begin
      if not (wc.Controls[i] is TGraphicControl) and not (csDestroying in wc.Controls[i].ComponentState) then begin
        if wc.Controls[i] is TWinControl then begin
          if TWinControl(wc.Controls[i]).HandleAllocated and TWinControl(wc.Controls[i]).Showing then SendAMessage(TWinControl(wc.Controls[i]).Handle, AC_ENDPARENTUPDATE)
        end
        else if wc.Controls[i] is TControl then SendAMessage(wc.Controls[i], AC_ENDPARENTUPDATE);
      end;
      inc(i);
    end;
  except
  end;
end;

procedure SetParentUpdated(pHwnd : hwnd); overload
var
  hCtrl : THandle;
begin
  hCtrl := GetTopWindow(pHwnd);
  while hCtrl <> 0 do begin
    if (GetWindowLong(hCtrl, GWL_STYLE) and WS_CHILD) = WS_CHILD then SendAMessage(hCtrl, AC_ENDPARENTUPDATE);
    hCtrl := GetNextWindow(hCtrl, GW_HWNDNEXT);
  end;
end;

procedure InitParentColor(Control : TWinControl);
begin
  ParentCenterColor := clFuchsia;
  SendMessage(Control.Handle, SM_ALPHACMD, MakeWParam(0, AC_GETCONTROLCOLOR), 0);
  if ParentCenterColor = clFuchsia then ParentCenterColor := TsHackedControl(Control).Color;
  ParentCenterColor := ColorToRGB(ParentCenterColor)
end;

function WorkRect: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
end;

function GetControlByName(ParentControl : TWinControl; const CtrlName : string) : TControl;
var
  i, j : integer;
  FrameName, cName : string;
  cf : TCustomFrame;
begin
  Result := nil;
  if ParentControl = nil then Exit;
  if pos('.', CtrlName) < 1 then for i := 0 to ParentControl.ComponentCount - 1 do begin
    if UpperCase(ParentControl.Components[i].Name) = UpperCase(CtrlName) then begin
      Result := TControl(ParentControl.Components[i]);
      Exit;
    end;
  end
  else begin
    FrameName := ExtractWord(1, CtrlName, ['.']);
    cName := ExtractWord(2, CtrlName, ['.']);
    if (FrameName = '') or (cName = '') then Exit;
    for i := 0 to ParentControl.ComponentCount - 1 do if (UpperCase(ParentControl.Components[i].Name) = UpperCase(FrameName)) then begin
      if (ParentControl.Components[i] is TCustomFrame) then begin
        cf := TCustomFrame(ParentControl.Components[i]);
        for j := 0 to cf.ComponentCount - 1 do if UpperCase(cf.Components[j].Name) = UpperCase(cName) then begin
          Result := TControl(cf.Components[j]);
          Exit;
        end
      end;
      Exit
    end;
  end;
end;

procedure PaintControls(DC: HDC; OwnerControl : TWinControl; ChangeCache : boolean; Offset : TPoint; AHandle : THandle = 0);
var
  SaveIndex : hdc;
  I, J, Count : Integer;
  R : TRect;
  tDC, MemDC: HDC;
  MemBitmap, OldBitmap: HBITMAP;
  MemDCExists : boolean;
  function ControlIsReady(Control : TControl) : boolean; begin
    Result := (Control.Visible or (csDesigning in Control.ComponentState)) and (Control is TGraphicControl) and ((Control.Width + Control.Height) > 0) and
           not (csNoDesignVisible in Control.ControlStyle) and not (csDestroying in Control.ComponentState) and
             not ((Control is TToolButton) and (TToolButton(Control).Style in [tbsCheck, tbsButton, tbsDropDown])) and
               RectVisible(DC, Control.BoundsRect) and (Control.Width > 0) and (Control.Height > 0);
  end;
begin
  MemDCExists := False;
  MemDC := 0;
  MemBitmap := 0;
  OldBitmap := 0;
  if (OwnerControl.Visible or (csDesigning in OwnerControl.ComponentState)) and
       (OwnerControl.ControlCount > 0) then try
    if (GetClipBox(DC, R) = NULLREGION) or (WidthOf(R) = 0) or (HeightOf(R) = 0) {v5.0} then begin
      SendAMessage(OwnerControl.Handle, AC_SETHALFVISIBLE);
      Exit;
    end;
    GlobalCacheInfo.Ready := False;
    SendMessage(OwnerControl.Handle, SM_ALPHACMD, MakeWParam(0, AC_GETCACHE), 0);
    if not GlobalCacheInfo.Ready then Exit;
    I := 0; Count := OwnerControl.ControlCount;

    while I < Count do begin
      if ControlIsReady(OwnerControl.Controls[I]) then begin
        if (OwnerControl is TForm) and
             (TForm(OwnerControl).FormStyle = fsMDIForm) and
               (OwnerControl.Controls[I].Align <> alNone) and
                 (OwnerControl.Controls[I] is TGraphicControl) then begin
          SendMessage(OwnerControl.Handle, SM_ALPHACMD, MakeWParam(0, AC_SETGRAPHCONTROL), longint(OwnerControl.Controls[I]));
          OwnerControl.Controls[I].Repaint;
          SendMessage(OwnerControl.Handle, SM_ALPHACMD, MakeWParam(0, AC_SETGRAPHCONTROL), 0);
        end;

        if not MemDCExists then begin
          tDC := GetDC(0);
          MemBitmap := CreateCompatibleBitmap(tDC, OwnerControl.Width, OwnerControl.Height);