suipublic.pas

来自「新颖按钮控件」· PAS 代码 · 共 365 行

////////////////////////////////////////////////////////////////////////////////
//
//
//  FileName    :   SUIPublic.pas
//  Creator     :   Shen Min
//  Date        :   2002-05-24
//  Comment     :
//
//  Copyright (c) 2002-2003 Sunisoft
//  http://www.sunisoft.com
//  Email: [e-mail]
//
////////////////////////////////////////////////////////////////////////////////

unit SUIPublic;

interface

uses Windows, Graphics, Controls, Messages, Classes, Forms, Dialogs, SysUtils,
     SUIThemes;

const
    SUI_ENTER = #13 + #10;
    SUI_2ENTER = SUI_ENTER + SUI_ENTER;


    procedure DoTrans(Canvas : TCanvas; Control : TWinControl);
    procedure TileDraw(const Canvas : TCanvas; const Picture : TPicture; const Rect : TRect);
    procedure SetWinControlTransparent(Control : TWinControl);
    procedure SpitDraw(Source : TBitmap; ACanvas : TCanvas; ARect : TRect; ATransparent : Boolean);
    procedure SpitDrawHorizontal(Source : TBitmap; ACanvas : TCanvas; ARect : TRect; ATransparent : Boolean);
    procedure DrawControlBorder(WinControl : TWinControl; BorderColor, Color : TColor);
    procedure RoundPicture(SrcBuf : TBitmap);

    procedure SetBitmapWindow(HandleOfWnd : HWND; const Bitmap : TBitmap; TransColor : TColor);

    function InRect(Point : TPoint; Rect : TRect) : Boolean; overload;
    function InRect(X, Y : Integer; Rect : TRect) : Boolean; overload;

    procedure PlaceControl(const Control : TControl; const Position : TPoint); overload;
    procedure PlaceControl(const Control : TControl; const Rect : TRect); overload;

    function GetWorkAreaRect() : TRect;

{$WARNINGS OFF}
    function PCharToStr(pstr : PChar) : String;
{$WARNINGS ON}
implementation


procedure DoTrans(Canvas : TCanvas; Control : TWinControl);
var
    DC : HDC;
    SaveIndex : HDC;
    Position: TPoint;
begin
    if Control.Parent <> nil then
    begin
        DC := Canvas.Handle;
        SaveIndex := SaveDC(DC);
        GetViewportOrgEx(DC, Position);
        SetViewportOrgEx(DC, Position.X - Control.Left, Position.Y - Control.Top, nil);
        IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
        Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
        Control.Parent.Perform(WM_PAINT, DC, 0);
        RestoreDC(DC, SaveIndex);
    end;
end;

procedure TileDraw(const Canvas : TCanvas; const Picture : TPicture; const Rect : TRect);
var
    i, j : Integer;
begin
    i := 0;
    While i < (Rect.Right - Rect.Left) + Picture.Width do
    begin
        j := 0;
        While j < (Rect.Bottom - Rect.Top) + Picture.Height do
        begin
            Canvas.Draw(i, j, Picture.Graphic);
            Inc(j, Picture.Height);
        end;
        Inc(i, Picture.Width);
    end;
end;

procedure SetWinControlTransparent(Control : TWinControl);
var
    WinStyle : DWORD;
begin
    Control.ControlStyle := Control.ControlStyle - [csOpaque];

    WinStyle := GetWindowLong(Control.Handle, GWL_EXSTYLE );
    WinStyle := WinStyle or WS_EX_TRANSPARENT;
    SetWindowLong(Control.Handle, GWL_EXSTYLE, WinStyle);
end;

function InRect(Point : TPoint; Rect : TRect) : Boolean;
begin
    Result := InRect(Point.X, Point.Y, Rect);
end;

function InRect(X, Y : Integer; Rect : TRect) : Boolean;
begin
    Result := false;

    if (
        (X >= Rect.Left) and
        (X <= Rect.Right) and
        (Y >= Rect.Top) and
        (Y <= Rect.Bottom)
    )then
        Result := True
end;

function GetWorkAreaRect() : TRect;
begin
{$WARNINGS OFF}
    SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
{$WARNINGS ON}
end;

procedure PlaceControl(const Control : TControl; const Position : TPoint);
begin
    Control.Left := Position.X;
    Control.Top := Position.Y;
end;

procedure PlaceControl(const Control : TControl; const Rect : TRect);
begin
    Control.Left := Rect.Left;
    Control.Top := Rect.Top;
    Control.Width := Rect.Right - Rect.Left;
    Control.Height := Rect.Bottom - Rect.Top;
end;

procedure SpitDraw(Source : TBitmap; ACanvas:TCanvas; ARect:TRect; ATransparent : Boolean);
var
    Buf, Buf2, Bmp : TBitmap;
    R : TRect;
    ImageList : TImageList;
    TransColor : TColor;
begin
    Bmp := TBitmap.Create;
    Buf := TBitmap.Create;
    Buf2 := TBitmap.Create;

    Try
        Buf.Width := ARect.Right - ARect.Left;
        Buf.Height := Source.Height;
        Buf2.Width := ARect.Right - ARect.Left;
        Buf2.Height := ARect.Bottom - ARect.Top;

        With Bmp do
        Begin
            Height := Source.Height;
            Width := Source.Width;
            Canvas.CopyRect(
                Rect(0, 0, Width, Height),
                Source.Canvas,
                Rect(0, 0, Width, Height)
            );
            Buf.Canvas.Draw(Buf.Width - Width, 0, Bmp);

            Width := 1;
            Canvas.CopyRect(
                Rect(0, 0, Width, Height),
                Source.Canvas,
                Rect(Source.Width div 2, 0, Source.Width div 2 + 1, Height)
            );
            Buf.Canvas.StretchDraw(
                Rect(0, 0, Buf.Width - Source.Width div 2, Height),
                Bmp
            );

            Width := Source.Width div 2;
            Canvas.CopyRect(
                Rect(0, 0, Width, Height),
                Source.Canvas,
                Rect(0, 0, Source.Width div 2, Height)
            );
            Buf.Canvas.Draw(0, 0, Bmp);

            Buf2.Canvas.CopyRect(
                Rect(0, 0, Buf.Width, Buf.Height div 2),
                Buf.Canvas,
                Rect(0, 0, Buf.Width, Buf.Height div 2)
            );
            Buf2.Canvas.CopyRect(
                Rect(0, Buf2.Height - Buf.Height div 2 - 1, Buf.Width, Buf2.Height),
                Buf.Canvas,
                Rect(0, Buf.Height div 2, Buf.Width, Buf.Height)
            );
            R := Rect(
                0,
                Buf.Height div 2,
                Buf2.Width,
                Buf2.Height - Buf.Height div 2 - 1
            );

            Bmp.Width := Buf2.Width;
            Bmp.Height := 1;
            Bmp.Canvas.CopyRect(
                Rect(0, 0, Bmp.Width, 1),
                Buf.Canvas,
                Rect(0, Buf.Height div 2, Buf.Width, Buf.Height div 2 + 1)
            );
            Buf2.Canvas.StretchDraw(R, Bmp);

            ImageList := TImageList.CreateSize(Buf2.Width, Buf2.Height);
            TransColor := Buf2.Canvas.Pixels[0, 0];
            try
                if ATransparent then
                    ImageList.AddMasked(Buf2, TransColor)
                else
                    ImageList.Add(Buf2, nil);
                ImageList.Draw(ACanvas, ARect.Left, ARect.Top, 0);
            finally
                ImageList.Free();
            end;
        End;

    Finally
        Bmp.Free;
        Buf.Free;
        Buf2.Free;
    End;
End;

procedure DrawControlBorder(WinControl : TWinControl; BorderColor, Color : TColor);
var
    DC : HDC;
    Brush : HBRUSH;
    R: TRect;
begin
    DC := GetWindowDC(WinControl.Handle);

    GetWindowRect(WinControl.Handle, R);
    OffsetRect(R, -R.Left, -R.Top);

    Brush := CreateSolidBrush(ColorToRGB(BorderColor));
    FrameRect(DC, R, Brush);
    DeleteObject(Brush);

    Brush := CreateSolidBrush(ColorToRGB(Color));
    R := Rect(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1);
    FrameRect(DC, R, Brush);
    DeleteObject(Brush);
    
    ReleaseDC(WinControl.Handle, DC);
end;

{$WARNINGS OFF}
function PCharToStr(pstr : PChar) : String;
begin
    if StrLen(pstr) = 0 then
        Result := ''
    else
    begin
        Result := pstr;
        SetLength(Result, StrLen(pstr));
    end;
end;
{$WARNINGS ON}

procedure SetBitmapWindow(HandleOfWnd : HWND; const Bitmap : TBitmap; TransColor : TColor);
var
    i, j : Integer;
    Left, Right : Integer;
    PreWhite : Boolean;
    TempRgn : HRgn;
    Rgn : HRgn;
begin
    Rgn := CreateRectRgn(0, 0, 0, 0);

    for i := 0 to Bitmap.Height - 1 do
    begin
        Left := 0;
        Right := 0;
        PreWhite := true;

        for j := 0 to Bitmap.Width - 1 do
        begin
            if (
                (Bitmap.Canvas.Pixels[j, i] = TransColor) or
                (j = Bitmap.Width - 1)
            ) then
            begin
                if (not PreWhite) then
                begin
                    TempRgn := CreateRectRgn(Left, i, Right + 1, i + 1);
                    CombineRgn(Rgn, Rgn, TempRgn, RGN_OR);
                    DeleteObject(TempRgn);
                end;
                PreWhite := true;
            end
            else
            begin
                if PreWhite then
                begin
                    Left := j;
                    Right := j;
                end
                else
                    Inc(Right);
                PreWhite := false;
            end;
        end;
    end;

    SetWindowRgn(HandleOfWnd, Rgn, true);
    DeleteObject(Rgn);
end;

procedure SpitDrawHorizontal(Source : TBitmap; ACanvas : TCanvas; ARect : TRect; ATransparent : Boolean);
var
    ImageList : TImageList;
    TransColor : TColor;
    R : TRect;
    TempBuf : TBitmap;
begin
    TransColor := Source.Canvas.Pixels[0, 0];
    ImageList := TImageList.Create(nil);
    ImageList.Height := Source.Height;
    ImageList.Width := Source.Width div 3;
    if ATransparent then
        ImageList.AddMasked(Source, TransColor)
    else
        ImageList.Add(Source, nil);

    ImageList.Draw(ACanvas, ARect.Left, ARect.Top, 0);
    ImageList.Draw(ACanvas, ARect.Right - ImageList.Width, ARect.Top, 2);
    R := Rect(ARect.Left + ImageList.Width, ARect.Top, ARect.Right - ImageList.Width, ARect.Bottom);
    TempBuf := TBitmap.Create();
    ImageList.GetBitmap(1, TempBuf);
    ACanvas.StretchDraw(R, TempBuf);
    TempBuf.Free();

    ImageList.Free();
end;

procedure RoundPicture(SrcBuf : TBitmap);
var
    Buf : TBitmap;
    i, j : Integer;
begin
    Buf := TBitmap.Create();

    Buf.Width := SrcBuf.Height;
    Buf.Height := SrcBuf.Width;

    for i := 0 to SrcBuf.Height do
        for j := 0 to SrcBuf.Width do
            Buf.Canvas.Pixels[i, (SrcBuf.Width - j - 1)] :=
                SrcBuf.Canvas.Pixels[j, i];

    SrcBuf.Height := Buf.Height;
    SrcBuf.Width := Buf.Width;
    SrcBuf.Canvas.Draw(0, 0, Buf);

    Buf.Free();
end;

end.