sputils.pas

灰鸽子VIP1.2经典源代码

  i: Integer;
  X, Y: Integer;
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    case Code of
      1:
        begin
          X := R.Left + RectWidth(R) div 2 - 2;
          Y := R.Top + RectHeight(R) div 2;
          for i := 0 to 3 do
          begin
            MoveTo(X + i, Y - i);
            LineTo(X + i, Y + i + 1);
          end;
        end;
      2:
        begin
          X := R.Left + RectWidth(R) div 2 + 2;
          Y := R.Top + RectHeight(R) div 2;
          for i := 3 downto 0 do
           begin
             MoveTo(X - i, Y + i);
             LineTo(X - i, Y - i - 1);
           end;
        end;
      3:
        begin
          X := R.Left + RectWidth(R) div 2;
          Y := R.Top + RectHeight(R) div 2 - 2;
          for i := 0 to 3 do
          begin
            MoveTo(X - i, Y + i);
            LineTo(X + i + 1, Y + i);
          end;
        end;
      4:
        begin
          X := R.Left + RectWidth(R) div 2;
          Y := R.Top + RectHeight(R) div 2 + 2;
          for i := 3 downto 0 do
          begin
            MoveTo(X - i, Y - i);
            LineTo(X + i + 1, Y - i);
          end;  
        end;
    end;
  end;
end;

procedure DrawRadioImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    Brush.Color := Color;
    Rectangle(X, Y, X + 6, Y + 6);
  end;
end;

procedure DrawCheckImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
var
  i: Integer;
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    for i := 0 to 2 do
    begin
      MoveTo(X, Y + 5 - i);
      LineTo(X + 2, Y + 7 - i);
      LineTo(X + 7, Y + 2 - i);
    end;
  end;
end;

function IsJpegFile(AFileName: String): Boolean;
begin
  Result := (Pos('.jpg', AFileName) <> 0) or
            (Pos('.jpeg', AFileName) <> 0);
end;

procedure LoadFromJPegImage(SB: TBitMap; JI: TJpegImage);
begin
  SB.Width := JI.Width;
  SB.Height := JI.Height;
  SB.Canvas.Draw(0, 0, JI);
end;

procedure LoadFromJpegStream(SB: TBitMap; AStream: TStream);
var
  JI: TJpegImage;
begin
  JI := TJpegImage.Create;
  JI.LoadFromStream(AStream);
  SB.Width := JI.Width;
  SB.Height := JI.Height;
  SB.Canvas.Draw(0, 0, JI);
  JI.Free;
end;

procedure LoadFromJpegFile(SB: TBitMap; AFileName: String);
var
  JI: TJpegImage;
begin
  JI := TJpegImage.Create;
  JI.LoadFromFile(AFileName);
  SB.Width := JI.Width;
  SB.Height := JI.Height;
  SB.Canvas.Draw(0, 0, JI);
  JI.Free;
end;


procedure Frm3D;
  procedure DoRect;
  var
    TopRight, BottomLeft: TPoint;
  begin
    with Canvas, Rect do
    begin
      TopRight.X := Right;
      TopRight.Y := Top;
      BottomLeft.X := Left;
      BottomLeft.Y := Bottom;
      Pen.Color := TopColor;
      PolyLine([BottomLeft, TopLeft, TopRight]);
      Pen.Color := BottomColor;
      Dec(BottomLeft.X);
      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom); Dec(Rect.Right);
  DoRect;
end;

procedure GetWindowsVersion(var Major, Minor: Integer);
var
  Ver : Longint;
begin
  Ver := GetVersion;
  Major := LoByte(LoWord(Ver));
  Minor := HiByte(LoWord(Ver));
end;

function CheckWXP: Boolean;
var
  Major, Minor : Integer;
begin
  GetWindowsVersion(major, minor);
  Result := (major = 5) and (minor = 1);
end;

function CheckW2kWXP: Boolean;
var
  Major, Minor : Integer;
begin
  GetWindowsVersion(major, minor);
  Result := (major = 5) and ((minor = 0) or (minor = 1)or (minor = 2));
end;

procedure SetAlphaBlendTransparent;
var
  User32: Cardinal;
  SetLayeredWindowAttributes: function (hwnd: LongInt; crKey: byte; bAlpha: byte; dwFlags: LongInt): LongInt; stdcall;
begin
  User32 := LoadLibrary('USER32');
  if User32 <> 0
  then
    try
     SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes');
     if @SetLayeredWindowAttributes <> nil
     then
       SetLayeredWindowAttributes(WHandle, 0, Value, LWA_ALPHA);
     finally
        FreeLibrary(User32);
     end;
end;

procedure GetScreenImage(X, Y: Integer; B: TBitMap);
var
  DC: HDC;
begin
  DC := GetDC(0);
  BitBlt(B.Canvas.Handle, 0, 0,
         B.Width, B.Height, DC, X, Y, SrcCopy);
  ReleaseDC(0, DC);
end;

function EqRects(R1, R2: TRect): Boolean;
begin
  Result := (R1.Left = R2.Left) and (R1.Top = R2.Top) and
            (R1.Right = R2.Right) and (R1.Bottom = R2.Bottom);
end;

function NullRect: TRect;
begin
  Result := Rect(0, 0, 0, 0);
end;

function IsNullRect(R: TRect): Boolean;
begin
  Result := (R.Right - R.Left <= 0) or (R.Bottom - R.Top <= 0)
end;

function IsNullPoint(P: TPoint): Boolean;
begin
  Result := (P.X = 0) or (P.Y = 0);
end;

function PointInRect(R: TRect; P: TPoint): Boolean;
begin
  Result := (P.X >= R.Left) and (P.Y >= R.Top) and
            (P.X <= R.Right) and (P.Y <= R.Bottom);
end;

function RectInRect(R1, R2: TRect): Boolean;
begin
  Result := PtInRect(R2, R1.TopLeft) and PtInRect(R2, R1.BottomRight)
end;

function RectToCenter(var R: TRect; Bounds: TRect): TRect;
begin
  OffsetRect(R, -R.Left, -R.Top);
  OffsetRect(R, (RectWidth(Bounds) - RectWidth(R)) div 2, (RectHeight(Bounds) - RectHeight(R)) div 2);
  OffsetRect(R, Bounds.Left, Bounds.Top);
  Result := R;
end;

function RectWidth;
begin
  Result := R.Right - R.Left;
end;

function RectHeight;
begin
  Result := R.Bottom - R.Top;
end;

const
    nums = '1234567890';
    symbols = ', ';

function GetPoint(S: String): TPoint;
var
  i, j: Integer;
  S1: String;
  SA: array[1..2] of String;
begin
  S1 := '';
  j := 1;
  for i := 1 to Length(S) do
  begin
    if S[i] = ','
    then
      begin
        SA[j] := S1;
        S1 := '';
        Inc(j);
      end
    else
      if Pos(S[i], nums) <> 0 then S1 := S1 + S[i];
  end;
  SA[j] := S1;
  Result := Point(StrToInt(SA[1]), StrToInt(SA[2]));;
end;

function GetRect(S: String): TRect;
var
  i, j: Integer;
  S1: String;
  SA: array[1..4] of String;
begin
  S1 := '';
  j := 1;
  for i := 1 to Length(S) do
  begin
    if S[i] = ','
    then
      begin
        SA[j] := S1;
        S1 := '';
        Inc(j);
      end
    else
      if Pos(S[i], nums) <> 0 then S1 := S1 + S[i];
  end;
  SA[j] := S1;
  Result := Rect(StrToInt(SA[1]), StrToInt(SA[2]),
                 StrToInt(SA[3]), StrToInt(SA[4]));
end;

function SetRect(R: TRect): String;
begin
  Result := IntToStr(R.Left) + ',' +
    IntToStr(R.Top) + ',' + IntToStr(R.Right) + ',' +
    IntToStr(R.Bottom);
end;

function ReadRect;
var
  S: String;
begin
  S := IniFile.ReadString(Section, Ident, '0,0,0,0');
  Result := GetRect(S);
end;

function ReadPoint;
var
  S: String;
begin
  S := IniFile.ReadString(Section, Ident, '0,0');
  Result := GetPoint(S);
end;

function ReadBoolean;
var
  I: Integer;
begin
  I := IniFile.ReadInteger(Section, Ident, 0);
  Result := I = 1;
end;

function ReadFontStyles;
var
  FS: TFontStyles;
  S: String;
begin
  S := IniFile.ReadString(Section, Ident, '');
  FS := [];
  if Pos('fsbold', S) <> 0 then FS := FS + [fsBold];
  if Pos('fsitalic', S) <> 0 then FS := FS + [fsItalic];
  if Pos('fsunderline', S) <> 0 then FS := FS + [fsUnderline];
  if Pos('fsstrikeout', S) <> 0 then FS := FS + [fsStrikeOut];
  Result := FS;
end;

procedure ReadStrings;
var
  Count, i: Integer;
begin
  Count := IniFile.ReadInteger(Section, Ident + 'linecount', 0);
  for i := 0 to Count - 1 do
    S.Add(IniFile.ReadString(Section, Ident + 'line' + IntToStr(i), ''));
end;

procedure ReadStrings1;
var
  Count, i: Integer;
begin
  Count := IniFile.ReadInteger(Section, Ident + 'count', 0);
  for i := 0 to Count - 1 do
    S.Add(IniFile.ReadString(Section, IntToStr(i), ''));
end;

procedure WriteRect;
var
  S: String;
begin
  S := IntToStr(R.Left) + ',' + IntToStr(R.Top) + ',' +
       IntToStr(R.Right) + ',' + IntToStr(R.Bottom);
  IniFile.WriteString(Section, Ident, S);
end;

procedure WritePoint;
var
  S: String;
begin
  S := IntToStr(P.X) + ',' + IntToStr(P.Y);
  IniFile.WriteString(Section, Ident, S);
end;

procedure WriteBoolean;
var
  I: Integer;
begin
  if B then I := 1 else I := 0;
  IniFile.WriteInteger(Section, Ident, I);
end;

procedure WriteFontStyles;
var
  S: String;
begin
  S := '';
  if fsBold in FS then S := S + 'fsbold';
  if fsItalic in FS
  then
    begin
      if Length(S) > 0 then S := S + ',';
      S := S + 'fsitalic';
    end;
  if fsUnderline in FS
  then
    begin
      if Length(S) > 0 then S := S + ',';
      S := S + 'fsunderline';
    end;
  if fsStrikeOut in FS
  then
    begin
      if Length(S) > 0 then S := S + ',';
      S := S + 'fsstrikeout';
    end;
  IniFile.WriteString(Section, Ident, S);
end;

procedure WriteStrings;
var
  i: Integer;
begin
  IniFile.WriteInteger(Section, Ident + 'linecount', S.Count);
  for i := 0 to S.Count - 1 do
    IniFile.WriteString(Section, Ident + 'line' + IntToStr(i), S[i]);
end;

procedure WriteStrings1;
var
  i: Integer;
begin
  IniFile.WriteInteger(Section, Ident + 'count', S.Count);
  for i := 0 to S.Count - 1 do
    IniFile.WriteString(Section, IntToStr(i), S[i]);
end;

function ReadAlignment;
var
  S: String;
begin
  S := IniFile.ReadString(Section, Ident, 'tacenter');
  if S = 'tacenter' then Result := taCenter else
  if S = 'taleftjustify' then Result := taLeftJustify else
  Result := taRightJustify;
end;

procedure WriteAlignment;
var
  S: String;
begin
  if A = taCenter then S := 'tacenter' else
  if A = taLeftJustify then S := 'taleftjustify' else
  S := 'tarightjustify';
  IniFile.WriteString(Section, Ident, S);