bsutils.pas

BusinessSkinForm Ver3.95 full source_汉化版_最新

  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 EqPoints(const Pt1, Pt2: TPoint): Boolean;
begin
  Result := (Pt1.X = Pt2.X) and (Pt1.Y = Pt2.Y);
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);
end;

{ TbsFBitmap }
constructor TbsFBitmap.Create(HBmp:Integer);
var
  Bmp:   Windows.TBITMAP;
  memDC: Integer;
begin
  GetObject(hBmp,SizeOf(Bmp),@Bmp);
  Width:=Bmp.bmWidth;
  Height:=Bmp.bmHeight;
  Size:=((Width*3)+(Width mod 4))*Height;
  with bmHeader do
  begin
    biSize:=SizeOf(bmHeader);
    biWidth:=Width;
    biHeight:=-Height;
    biPlanes:=1;
    biBitCount:=24;
    biCompression:=BI_RGB;
  end;
  bmInfo.bmiHeader:=bmHeader;
  Handle:=CreateDIBSection(0,
                 bmInfo,
                 DIB_RGB_COLORS,
                 Bits, 0, 0);
  memDC:=GetDC(0);
  GetDIBits(memDC,hBmp,0,Height,Bits,bmInfo,DIB_RGB_COLORS);
  ReleaseDC(0,memDC);
  Initialize;
end;

destructor TbsFBitmap.Destroy;
begin
  DeleteDC(hDC);
  DeleteObject(Handle);
  FreeMem(Pixels);
  inherited;
end;

procedure TbsFBitmap.Initialize;
var
  x,i: Integer;
begin
  GetMem(Pixels,Height*SizeOf(PBLine));
  RowInc:=(Width*3)+Width mod 4;
  Gap:=Width mod 4;
  Size:=RowInc*Height;
  x:=Integer(Bits);
  for i:=0 to Height-1 do
  begin
    Pixels[i]:=Pointer(x);
    Inc(x,RowInc);
  end;
  hDC:=CreateCompatibleDC(0);
  SelectObject(hDC,Handle);
end;

// Region convert
function CreateRgnFromBmp(B: TBitmap; XO, YO: Integer; var RgnData: PRgnData): integer;
const
  max = 10000;
var
  j, i, i1: integer;
  C: TFBColor;
  FB: TbsFBitmap;
  Rts: array [0..max] of TRect;
  Count: integer;
begin
  Result := 0;
  If B.Empty Then Exit;
  Count := 0;
  FB := TbsFBitmap.Create(B.Handle);
  for j := 0 to FB.Height - 1 do
  begin
    i := 0;
    while i < FB.Width do
    begin
      C := FB.Pixels[j, i];
      If C.R + C.G + C.B = 0 Then
      begin
        i1 := i;
        C := FB.Pixels[j, i1];
        while C.R + C.G + C.B = 0 do
        begin
          Inc(i1);
          If i1 > FB.Width - 1 Then Break else C := FB.Pixels[j, i1];
        end;
        Rts[Count] := Rect(i + XO, j + YO, i1 + XO, j + 1 + YO);
        Inc(Count);
        i := i1;
        Continue;
      end;
      Inc(i);
    end;
  end;
  FB.Free;
  // Make Region data
  Result := Count*SizeOf(TRect);
  GetMem(Rgndata, SizeOf(TRgnDataHeader)+Result);
  FillChar(Rgndata^, SizeOf(TRgnDataHeader)+Result, 0);
  RgnData^.rdh.dwSize := SizeOf(TRgnDataHeader);
  RgnData^.rdh.iType := RDH_RECTANGLES;
  RgnData^.rdh.nCount := Count;
  RgnData^.rdh.nRgnSize := 0;
  RgnData^.rdh.rcBound := Rect(0 + XO, 0 + YO, B.Width + XO, B.Height + YO);
  // Update New Region
  Move(Rts, RgnData^.Buffer, Result);
  Result := SizeOf(TRgnDataHeader)+Count*SizeOf(TRect);
end;

procedure WriteStringToStream(Str: String; S: TStream);
var
  L: Integer;
begin
  L := Length(Str);
  S.Write(L, SizeOf(Integer));
  S.Write(Pointer(Str)^, L);
end;


procedure ReadStringFromStream(var Str: String; S: TStream);
var
  L: Integer;
begin
  L := 0;
  S.Read(L, SizeOf(Integer));
  SetLength(Str, L);