sputils.pas

一款支持Delphi和C++ Builder的VCL控件

          begin
            Brush.Color := AColorMarkerValue;
            Brush.Style := bsSolid;
            if ADown
            then
              FillRect(Rect(R.Left + 4, R.Top + 5, R.Right - 2, R.Bottom - 3))
            else
              FillRect(Rect(R.Left + 4, R.Top + 4, R.Right - 2, R.Bottom - 4));
          end;
     end;
end;

procedure DrawGlyphAndText(Cnvs: TCanvas;
  R: TRect; Margin, Spacing: Integer; Layout: TspButtonLayout;
  Caption: String; Glyph: TBitMap; NumGlyphs, GlyphNum: Integer; ADown: Boolean;
  ADrawColorMarker: Boolean; AColorMarkerValue: TColor);
var
  gw, gh: Integer;
  tw, th: Integer;
  TX, TY, GX, GY: Integer;
  TR: TRect;
begin
  if Glyph.Empty
  then
    begin
      gw := 0;
      gh := 0;
    end
  else
    begin
      gw := Glyph.Width div NumGlyphs;
      gh := Glyph.Height;
    end;
  with Cnvs do
  begin
    if Caption = ''
    then
      begin
        tw := 0;
        th := 0;
      end
    else
      begin
        TR := Rect(0, 0, RectWidth(R), RectHeight(R));
        if (Layout = blGlyphLeft) or (Layout = blGlyphRight)
        then
          begin
            Dec(TR.Right, gw);
          end
        else
        if (Layout = blGlyphTop) or (Layout = blGlyphBottom)
        then
          begin
            Dec(TR.Bottom, gh);
          end;
        DrawText(Handle, PChar(Caption), Length(Caption), TR,
                 DT_EXPANDTABS or DT_WORDBREAK or DT_CALCRECT);
        tw := RectWidth(TR);
        th := RectHeight(TR);
        Brush.Style := bsClear;
     end;
  end;

  CalcLCoord(Layout, R, gw, gh, tw, th, Spacing, Margin, TX, TY, GX, GY);

  if ADown
  then
    begin
      Inc(GX); Inc(GY);
      Inc(TX); Inc(TY);
    end;

  if Caption <> ''
  then
    begin
      TR := Rect(TX, TY, TX + tw, TY + th);
      Inc(TR.Right, 2);
      DrawText(Cnvs.Handle, PChar(Caption),
        Length(Caption), TR, DT_EXPANDTABS or DT_VCENTER or DT_CENTER or DT_WORDBREAK);
    end;
      
  if not Glyph.Empty then DrawGlyph(Cnvs, GX, GY, Glyph, NumGlyphs, GlyphNum);

  if not Glyph.Empty
  then
    begin
      if ADrawColorMarker
      then
        with Cnvs do
        begin
          Pen.Color := AColorMarkerValue;
          MoveTo(GX, GY + Glyph.Height - 2);
          LineTo(GX + Glyph.Width, GY + Glyph.Height - 2);
          MoveTo(GX, GY + Glyph.Height - 1);
          LineTo(GX + Glyph.Width, GY + Glyph.Height - 1);
          MoveTo(GX, GY + Glyph.Height);
          LineTo(GX + Glyph.Width, GY + Glyph.Height);
        end;
    end
  else
    if ADrawColorMarker
    then
      with Cnvs do
      begin
        if Caption <> ''
        then
          begin
            Pen.Color := AColorMarkerValue;
            MoveTo(TR.Left, TR.Bottom  - 1);
            LineTo(TR.Right, TR.Bottom  - 1);
            MoveTo(TR.Left, TR.Bottom);
            LineTo(TR.Right, TR.Bottom);
            MoveTo(TR.Left, TR.Bottom  + 1);
            LineTo(TR.Right, TR.Bottom  + 1);
          end
        else
          begin
            Brush.Color := AColorMarkerValue;
            Brush.Style := bsSolid;
            if ADown
            then
              FillRect(Rect(R.Left + 4, R.Top + 5, R.Right - 2, R.Bottom - 3))
            else
              FillRect(Rect(R.Left + 4, R.Top + 4, R.Right - 2, R.Bottom - 4));
          end;
     end;

end;


function MyGetScrollBarInfo(wnd: Cardinal; idObject: Longint; var psbi: TScrollBarInfo): BOOL;
begin
  if @GetScrollBarInfoFunc <> nil then
    Result := GetScrollBarInfoFunc(wnd, idObject, psbi)
  else
  begin
    { Win95 }
    psbi.rgstate[0] := STATE_SYSTEM_INVISIBLE;
    Result := false;
  end;
end;

procedure CorrectTextbyWidth(C: TCanvas; var S: String; W: Integer);
var
  j: Integer;
begin
  j := Length(S);
  with C do
  begin
    if TextWidth(S) > w
    then
      begin
        repeat
          Delete(S, j, 1);
          Dec(j);
        until (TextWidth(S + '...') <= w) or (S = '');
        S := S + '...';
      end;
  end;
end;


procedure GetControls(X, Y, W, H: Integer;
                      Control: TCustomControl; Dest: TCanvas);
var
  I, Count, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
  Ctrl: TControl;
begin
  Count := Control.ControlCount;
  DC := Dest.Handle;
  SelfR := Bounds(0, 0, W, H);
  // Copy images of controls
  for I := 0 to Count - 1 do
  begin
    Ctrl := Control.Controls[I];
    if (Ctrl <> nil) and (Ctrl is TCustomControl)
    then
      begin
        with Ctrl do
        begin
          CtlR := Bounds(X + Left, Y + Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
          begin
            SaveIndex := SaveDC(DC);
            SetViewportOrgEx(DC, Left + X, Top + Y, nil);
            IntersectClipRect(DC, 0, 0, Width, Height);
            Perform(WM_PAINT, DC, 0);
            RestoreDC(DC, SaveIndex);
            if TCustomControl(Ctrl).ControlCount <> 0
            then
              GetControls(Left + X, Top + Y, W, H,
              TCustomControl(Ctrl), Dest);
          end;
       end;
    end;
  end;
end;


procedure GetParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
       if (Control.Parent is TForm) and
          (TForm(Control.Parent).FormStyle = fsMDIForm)
       then
         begin
           SendMessage(TForm(Control.Parent).ClientHandle, WM_ERASEBKGND, DC, 0);
         end
      else
      if Control.Parent is TspSkinTabControl
      then
        begin
          TspSkinTabControl(Control.Parent).PaintBG(DC);
       end
      else
      with TParentControl(Control.Parent) do begin
        Perform(WM_ERASEBKGND, DC, 0);
        if not (Control.Parent is TForm) then PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;

    for I := 0 to Count - 1 do
    if Control.Parent.Controls[I] <> Control
    then
    begin
      if (Control.Parent.Controls[I] <> nil) and
         (Control.Parent.Controls[I] is TGraphicControl)
      then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SaveIndex := SaveDC(DC);
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end;
    end
    else
      Break;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;


procedure GetParentImageRect(Control: TControl; Rct: TRect; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left - Rct.Left; Y := -Top - Rct.Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      if (Control.Parent is TForm) and
         (TForm(Control.Parent).FormStyle = fsMDIForm)
       then
         begin
           SendMessage(TForm(Control.Parent).ClientHandle, WM_ERASEBKGND, DC, 0);
         end
      else
      if Control.Parent is TspSkinTabControl
      then
        begin
          TspSkinTabControl(Control.Parent).PaintBG(DC);
       end
      else
      with TParentControl(Control.Parent) do begin
        Perform(WM_ERASEBKGND, DC, 0);
        if not (Control.Parent is TForm) then PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    
    for I := 0 to Count - 1 do
    if Control.Parent.Controls[I] <> Control
    then
    begin
      if (Control.Parent.Controls[I] <> nil) and
         (Control.Parent.Controls[I] is TGraphicControl)
      then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SaveIndex := SaveDC(DC);
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end
    end
    else
      Break;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;


function CalcTextWidthW(C: TCanvas; Str: WideString): Integer;
var
  R: TRect;
begin
  R := Rect(0, 0, 0, 0);
  SPDrawSkinText(C, Str, R, DT_CALCRECT);
  Result := RectWidth(R);
end;

function CalcTextHeightW(C: TCanvas; Str: WideString): Integer;
var
  R: TRect;
begin
  R := Rect(0, 0, 0, 0);
  SPDrawSkinText(C, Str, R, DT_CALCRECT);
  Result := RectHeight(R);
end;

procedure CorrectTextbyWidthW(C: TCanvas; var S: WideString; W: Integer);

function GetTextWidth(Str: WideString): Integer;
var
  R: TRect;
begin
  R := Rect(0, 0, 0, 0);
  SPDrawSkinText(C, Str, R, DT_CALCRECT);
  Result := RectWidth(R);
end;

var
  j: Integer;
begin
  j := Length(S);
  if GetTextWidth(S) > w
  then
   begin
     repeat
       Delete(S, j, 1);
       Dec(j);
     until (GetTextWidth(S + '...') <= w) or (S = '');
    S := S + '...';
  end;
end;

function SPDrawSkinText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag: cardinal): integer;
var
  AnsiText: string;
begin
  if SP_PlatformIsUnicode
  then
    Result := Windows.DrawTextW(ACanvas.Handle, PWideChar(AText), Length(AText), Bounds, Flag)
  else
  begin
    AnsiText := WideCharToString(PWideChar(AText));
    Result := Windows.DrawText(ACanvas.Handle, PChar(AnsiText), Length(AnsiText), Bounds, Flag);
  end;
end;

procedure SPDrawText(Cnvs: TCanvas; S: String; R: TRect);
begin
  if S = '' then Exit;
  DrawText(Cnvs.Handle, PChar(S), Length(S), R,
    DT_VCENTER or DT_SINGLELINE or DT_LEFT);
end;

function Max(A, B: Longint): Longint;
begin
  if A > B then Result := A
  else Result := B;
end;

function Min(A, B: Longint): Longint;
begin
  if A < B then Result := A
  else Result := B;
end;


procedure SPDrawText2(Cnvs: TCanvas; S: String; R: TRect);
var
  TX, TY: Integer;
begin
  if S = '' then Exit;
  TX := R.Left + 2;
  TY := R.Top + RectHeight(R) div 2 - Cnvs.TextHeight(S) div 2;
  Cnvs.TextRect(R, TX, TY, S);
end;

procedure SPDrawText3(Cnvs: TCanvas; S: String; R: TRect; HorOffset: Integer);
var
  TX, TY: Integer;
begin
  if S = '' then Exit;
  TX := R.Left + 2 + HorOffset;