sputils.pas

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

    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;

{ TFBitmap }
constructor TFBitmap.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 TFBitmap.Destroy;
begin
  DeleteDC(hDC);
  DeleteObject(Handle);
  FreeMem(Pixels);
  inherited;
end;

procedure TFBitmap.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: TFBitmap;
  Rts: array [0..max] of TRect;
  Count: integer;
begin
  Result := 0;
  If B.Empty Then Exit;
  Count := 0;
  FB := TFBitmap.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);
  S.Read(Pointer(Str)^, L);
end;

procedure CreateStretchImage;
var
  LTPt, RTPt, LBPt, RBPt: TPoint;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint;
  NewClRect: TRect;
begin
  LtPt := Point(ClRect.Left, ClRect.Top);
  RtPt := Point(ClRect.Right, ClRect.Top);
  LBPt := Point(ClRect.Left, ClRect.Bottom);
  RBPt := Point(ClRect.Right, ClRect.Bottom);

  NewClRect := ClRect;
  NewClRect.Right := B.Width - (RectWidth(R) - ClRect.Right);
  NewClRect.Bottom := B.Height - (RectHeight(R) - ClRect.Bottom);

  NewLtPt := Point(NewClRect.Left, NewClRect.Top);
  NewRtPt := Point(NewClRect.Right, NewClRect.Top);
  NewLBPt := Point(NewClRect.Left, NewClRect.Bottom);
  NewRBPt := Point(NewClRect.Right, NewClRect.Bottom);

  CreateSkinImage(LtPt, RTPt, LBPt, RBPt, ClRect,
    NewLTPt, NewRTPt, NewLBPt, NewRBPt, NewClRect,
    B, SB, R, B.Width, B.Height, ADrawClient,
    True, True, True, True, True, spstFull);
end;


procedure CreateHSkinImage;
var
  X, XCnt, w, XO: Integer;
  R1: TRect;
  Buffer: TBitMap;
begin
  B.Width := AW;
  B.Height := RectHeight(R);
  with B.Canvas do
  begin
    if LO <> 0 then
       CopyRect(Rect(0, 0, LO, B.Height), SB.Canvas,
                Rect(R.Left, R.Top, R.Left + LO, R.Bottom));
    if RO <> 0 then
       CopyRect(Rect(B.Width - RO, 0, B.Width, B.Height),
                SB.Canvas,
                Rect(R.Right - RO, R.Top, R.Right, R.Bottom));
    Inc(R.Left, LO);
    Dec(R.Right, RO);
    w := RectWidth(R);
    if w = 0 then w := 1;
    XCnt := (B.Width - LO - RO) div w;
    if AStretch
    then
      begin
        Buffer := TBitMap.Create;
        Buffer.Width := RectWidth(R);
        Buffer.Height := RectHeight(R);
        Buffer.Canvas.CopyRect(Rect(0, 0, Buffer.Width, Buffer.Height),
         SB.Canvas, R);
        R1 := Rect(LO, 0, B.Width - RO, B.Height);
        B.Canvas.StretchDraw(R1, Buffer);
        Buffer.Free;
      end
    else
    for X := 0 to XCnt do
    begin
      if LO + X * w + w > B.Width - RO
      then XO := LO + X * w + w - (B.Width - RO)
      else XO := 0;
      B.Canvas.CopyRect(Rect(LO + X * w, 0, LO + X * w + w - XO,
                        B.Height),
                        SB.Canvas,
                        Rect(R.Left, R.Top, R.Right - XO, R.Bottom));
    end;
  end;
end;

procedure CreateHSkinImage2;
var
  X, XCnt, w, XO: Integer;
  R1: TRect;
  Buffer: TBitMap;
begin
  B.Width := AW;
  B.Height := RectHeight(R);
  with B.Canvas do
  begin
    if LO <> 0 then
       CopyRect(Rect(0, 0, LO, B.Height), SB.Canvas,
                Rect(R.Left, R.Top, R.Left + LO, R.Bottom));
    Inc(R.Left, LO);
    Dec(R.Right, RO);
    w := RectWidth(R);
    if w = 0 then w := 1;
    XCnt := (B.Width - LO) div w;
    if AStretch
    then
      begin
        Buffer := TBitMap.Create;
        Buffer.Width := RectWidth(R);
        Buffer.Height := RectHeight(R);
        Buffer.Canvas.CopyRect(Rect(0, 0, Buffer.Width, Buffer.Height),
         SB.Canvas, R);
        R1 := Rect(LO, 0, B.Width, B.Height);
        B.Canvas.StretchDraw(R1, Buffer);
        Buffer.Free;
      end
    else
    for X := 0 to XCnt do
    begin
      if LO + X * w + w > B.Width
      then XO := LO + X * w + w - B.Width
      else XO := 0;
      B.Canvas.CopyRect(Rect(LO + X * w, 0, LO + X * w + w - XO,
                        B.Height),
                        SB.Canvas,
                        Rect(R.Left, R.Top, R.Right - XO, R.Bottom));
    end;
  end;
end;

procedure CreateHSkinImage3;
var
  X, XCnt, w, XO: Integer;
  R1: TRect;
  Buffer: TBitMap;
begin
  B.Width := AW;
  B.Height := RectHeight(R);
  with B.Canvas do
  begin
    Inc(R.Left, LO);
    Dec(R.Right, RO);
    w := RectWidth(R);
    if w = 0 then w := 1;
    XCnt := B.Width div w;
    if AStretch
    then
      begin
        Buffer := TBitMap.Create;
        Buffer.Width := RectWidth(R);
        Buffer.Height := RectHeight(R);
        Buffer.Canvas.CopyRect(Rect(0, 0, Buffer.Width, Buffer.Height),
          SB.Canvas, R);
        R1 := Rect(0, 0, B.Width, B.Height);
        B.Canvas.StretchDraw(R1, Buffer);
        Buffer.Free;
      end
    else
    for X := 0 to XCnt do
    begin
      if LO + X * w + w > B.Width
      then XO := LO + X * w + w - B.Width
      else XO := 0;
      B.Canvas.CopyRect(Rect(X * w, 0, X * w + w - XO,
                        B.Height),
                        SB.Canvas,
                        Rect(R.Left, R.Top, R.Right - XO, R.Bottom));
    end;
  end;
end;


procedure CreateVSkinImage;
var
  Y, YCnt, h, YO: Integer;
  R1: TRect;
  Buffer: TBitMap;
begin
  B.Width := RectWidth(R);
  B.Height := AH;
  with B.Canvas do
  begin
    if TpO <> 0 then
       CopyRect(Rect(0, 0, B.Width, TpO), SB.Canvas,
                Rect(R.Left, R.Top, R.Right, R.Top + TpO));
    if BO <> 0 then
       CopyRect(Rect(0, B.Height - BO, B.Width, B.Height),
                SB.Canvas,
                Rect(R.Left, R.Bottom - BO, R.Right, R.Bottom));
    Inc(R.Top, TpO);
    Dec(R.Bottom, BO);
    h := RectHeight(R);
    if H <> 0
    then
      YCnt := (B.Height - TpO - BO) div h
    else
      YCnt := 0;
    if AStretch
    then
      begin
        Buffer := TBitMap.Create;
        Buffer.Width := RectWidth(R);
        Buffer.Height := RectHeight(R);
        Buffer.Canvas.CopyRect(Rect(0, 0, Buffer.Width, Buffer.Height),
         SB.Canvas, R);
        R1 := Rect(0, TpO, B.Width, B.Height - BO);
        B.Canvas.StretchDraw(R1, Buffer);
        Buffer.Free;
      end
    else
    for Y := 0 to YCnt do
    begin
      if TpO + Y * h + h > B.Height - BO
      then YO := TpO + Y * h + h - (B.Height - BO)
      else YO := 0;
      B.Canvas.CopyRect(
        Rect(0, TpO + Y * h, B.Width, TpO + Y * h + h - YO),
        SB.Canvas,
        Rect(R.Left, R.Top, R.Right, R.Bottom - YO));
    end;
  end;
end;


procedure CreateSkinImageBS;
var
  w, h, rw, rh: Integer;
  X, Y, XCnt, YCnt: Integer;
  XO, YO: Integer;
  Rct, SRct: TRect;
  Buffer, Buffer2: TBitMap;
  SaveIndex: Integer;
begin
  B.Width := AW;
  B.Height := AH;
  if (RBPt.X - LTPt.X  = 0) or
     (RBPt.Y - LTPt.Y = 0) or SB.Empty then  Exit;
  with B.Canvas do
  begin
    // Draw lines
    // top
    if not TS
    then
      begin
        w := RTPt.X - LTPt.X;
        XCnt := (NewRTPt.X - NewLTPt.X) div (RTPt.X - LTPt.X);
        for X := 0 to XCnt do
        begin
          if NewLTPt.X + X * w + w > NewRTPt.X
          then XO := NewLTPt.X + X * w + w - NewRTPt.X else XO := 0;
          CopyRect(Rect(NewLTPt.X + X * w, 0, NewLTPt.X + X * w + w - XO, NewClRect.Top),
               SB.Canvas, Rect(R.Left + LTPt.X, R.Top,
                 R.Left + RTPt.X - XO, R.Top + ClRect.Top));
        end;
      end
    else
      begin
        Buffer := TBitMap.Create;
        Buffer.Width := RTPt.X - LTPt.X;
        Buffer.Height := CLRect.Top;
        Rct := Rect(R.Left + LTPt.X, R.Top, R.Left + RTPt.X, R.Top + CLRect.Top);
        Buffer.Canvas.CopyRect(Rect(0, 0, Buffer.Width, Buffer.Height),
          SB.Canvas, Rct);
        SRct := Rect(NewLTPt.X, 0, NewRTPt.X, NewCLRect.Top);
        StretchDraw(SRct, Buffer);
        Buffer.Free;
      end;
    // bottom
    if not BS
    then
      begin
        w := RBPt.X - LBPt.X;
        XCnt := (NewRBPt.X - NewLBPt.X) div (RBPt.X - LBPt.X);
        for X := 0 to XCnt do
        begin
         if NewLBPt.X + X * w + w > NewRBPt.X
         then XO := NewLBPt.X + X * w + w - NewRBPt.X else XO := 0;
           CopyRect(Rect(NewLBPt.X + X * w, NewClRect.Bottom, NewLBPt.X + X * w + w - XO, AH),
                    SB.Canvas, Rect(R.Left + LBPt.X, R.Top + ClRect.Bottom,
                     R.Left + RBPt.X - XO, R.Bottom));
        end;             
      end
    else