frxutils.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

  img.Free;
end;

procedure DrawBitmap(aCanvas:TCanvas; Dest:TRect; Bitmap:TBitmap);
var
  Info:PBitmapInfo;
  HInfo:HGLOBAL;
  InfoSize:DWord;
  Image:Pointer;
  HImage:HGLOBAL;
  ImageSize:DWord;
begin
  with Bitmap do
  begin
    GetDIBSizes(Handle, InfoSize, ImageSize);
    HInfo:= GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, InfoSize);
    Info:= PBitmapInfo(GlobalLock(HInfo));
    try
      HImage:= GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, ImageSize);
      Image:= Pointer(GlobalLock(HImage));
      try
        GetDIB(Handle, Palette, Info^, Image^);
        if not Monochrome then
          SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
        with Info^.bmiHeader do
          StretchDIBits(aCanvas.Handle, Dest.Left, Dest.Top,
            Dest.RIght-Dest.Left, Dest.Bottom-Dest.Top,
            0, 0, biWidth, biHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
      finally
        GlobalUnlock(HImage);
        GlobalFree(HImage);
      end;
    finally
      GlobalUnlock(HInfo);
      GlobalFree(HInfo);
    end;
  end;
end;

procedure frxDrawGraphic(Canvas:TCanvas; DestRect:TRect; aGraph:TGraphic);
var
  Bitmap:TBitmap;
begin
  if aGraph is TMetaFile then
    Canvas.StretchDraw(DestRect, aGraph)
  else
  begin
    Bitmap:= TBitmap.Create;
    try
      Bitmap.Width:= aGraph.Width;
      Bitmap.Height:= aGraph.Height;
      Bitmap.PixelFormat:= pf32Bit;
      Bitmap.Canvas.Draw(0, 0, aGraph);
      DrawBitmap(Canvas, DestRect, Bitmap);
    finally
      Bitmap.Free;
    end;
  end;
end;

procedure frxParsePageNumbers(const PageNumbers:String; List:TStrings;
  Total:Integer);
var
  i, j, n1, n2:Integer;
  s:String;
  IsRange:Boolean;
begin
  List.Clear;
  s:= PageNumbers;
  while Pos(' ', s)<>0 do
    Delete(s, Pos(' ', s), 1);
  if s = '' then Exit;

  if s[Length(s)] = '-' then
    s:= s+IntToStr(Total);
  s:= s+',';
  i:= 1; j:= 1; n1:= 1;
  IsRange:= False;

  while i <= Length(s) do
  begin
    if s[i] = ',' then
    begin
      n2:= StrToInt(Copy(s, j, i-j));
      j:= i+1;
      if IsRange then
        while n1 <= n2 do
        begin
          List.Add(IntToStr(n1));
          Inc(n1);
        end
      else
        List.Add(IntToStr(n2));
      IsRange:= False;
    end
    else if s[i] = '-' then
    begin
      IsRange:= True;
      n1:= StrToInt(Copy(s, j, i-j));
      j:= i+1;
    end;
    Inc(i);
  end;
end;

{$IFNDEF Delphi6}
function Utf8Encode(const WS:WideString):String;
var
  L:Integer;
  Temp:String;

  function ToUtf8(Dest:PChar; MaxDestBytes:Cardinal;
           Source:PWideChar; SourceChars:Cardinal):Cardinal;
  var
    i, count:Cardinal;
    c:Cardinal;
  begin
    Result:= 0;
    if Source = nil then Exit;
    count:= 0;
    i:= 0;
    if Dest<>nil then
    begin
      while (i < SourceChars) and (count < MaxDestBytes) do
      begin
        c:= Cardinal(Source[i]);
        Inc(i);
        if c <= $7F then
        begin
          Dest[count]:= Char(c);
          Inc(count);
        end
        else if c > $7FF then
        begin
          if count+3 > MaxDestBytes then
            break;
          Dest[count]:= Char($E0 or (c shr 12));
          Dest[count+1]:= Char($80 or ((c shr 6) and $3F));
          Dest[count+2]:= Char($80 or (c and $3F));
          Inc(count,3);
        end
        else // $7F < Source[i] <= $7FF
        begin
          if count+2 > MaxDestBytes then
            break;
          Dest[count]:= Char($C0 or (c shr 6));
          Dest[count+1]:= Char($80 or (c and $3F));
          Inc(count,2);
        end;
      end;
      if count >= MaxDestBytes then count:= MaxDestBytes-1;
      Dest[count]:= #0;
    end
    else
    begin
      while i < SourceChars do
      begin
        c:= Integer(Source[i]);
        Inc(i);
        if c > $7F then
        begin
          if c > $7FF then
            Inc(count);
          Inc(count);
        end;
        Inc(count);
      end;
    end;
    Result:= count+1;
  end;

begin
  Result:= '';
  if WS = '' then Exit;
  SetLength(Temp, Length(WS) * 3);
  L:= ToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp:= '';
  Result:= Temp;
end;

function Utf8Decode(const S:String):WideString;
var
  L:Integer;
  Temp:WideString;

  function Utf8ToUnicode(Dest:PWideChar; MaxDestChars:Cardinal; Source:PChar; SourceBytes:Cardinal):Cardinal;
  var
    i, count:Cardinal;
    c:Byte;
    wc:Cardinal;
  begin
    if Source = nil then
    begin
      Result:= 0;
      Exit;
    end;
    Result:= Cardinal(-1);
    count:= 0;
    i:= 0;
    if Dest<>nil then
    begin
      while (i < SourceBytes) and (count < MaxDestChars) do
      begin
        wc:= Cardinal(Source[i]);
        Inc(i);
        if (wc and $80)<>0 then
        begin
          wc:= wc and $3F;
          if i > SourceBytes then Exit; // incomplete multibyte char
          if (wc and $20)<>0 then
          begin
            c:= Byte(Source[i]);
            Inc(i);
            if (c and $C0)<>$80 then Exit; // malformed trail byte or out of range char
            if i > SourceBytes then Exit; // incomplete multibyte char
            wc:= (wc shl 6) or (c and $3F);
          end;
          c:= Byte(Source[i]);
          Inc(i);
          if (c and $C0)<>$80 then Exit; // malformed trail byte

          Dest[count]:= WideChar((wc shl 6) or (c and $3F));
        end
        else
          Dest[count]:= WideChar(wc);
        Inc(count);
      end;
    if count >= MaxDestChars then count:= MaxDestChars-1;
    Dest[count]:= #0;
    end
    else
    begin
    while (i <= SourceBytes) do
    begin
      c:= Byte(Source[i]);
      Inc(i);
      if (c and $80)<>0 then
      begin
      if (c and $F0) = $F0 then Exit; // too many bytes for UCS2
      if (c and $40) = 0 then Exit; // malformed lead byte
      if i > SourceBytes then Exit; // incomplete multibyte char

      if (Byte(Source[i]) and $C0)<>$80 then Exit; // malformed trail byte
      Inc(i);
      if i > SourceBytes then Exit; // incomplete multibyte char
      if ((c and $20)<>0) and ((Byte(Source[i]) and $C0)<>$80) then Exit; // malformed trail byte
      Inc(i);
      end;
      Inc(count);
    end;
    end;
    Result:= count+1;
  end;

begin
  Result:= '';
  if S = '' then Exit;
  SetLength(Temp, Length(S));

  L:= Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp:= '';
  Result:= Temp;
end;
{$ENDIF}

function HTMLRGBColor(Color:TColor):string;
var
  TheRgbValue:TColorRef;
begin
  TheRgbValue:= ColorToRGB(Color);
  Result:= '#'+Format('%.2x%.2x%.2x', [GetRValue(TheRGBValue), GetGValue(TheRGBValue), GetBValue(TheRGBValue)]);
end;

procedure ConvertOneItem(Item:TCollectionItem; ToAnsi:Boolean);
var
  i:Integer;
  TypeInfo:PTypeInfo;
  PropCount:Integer;
  PropList:PPropList;

  function Convert(const Value:String):String;
  var
    i:Integer;
  begin
    Result:= '';
    i:= 1;
    while i <= Length(Value) do
    begin
      if ToAnsi then
      begin
        if Value[i] >= #128 then
          Result:= Result+#1+Chr(Ord(Value[i])-128) else
          Result:= Result+Value[i];
      end
      else
      begin
        if (Value[i] = #1) and (i < Length(Value)) then
        begin
          Result:= Result+Chr(Ord(Value[i+1])+128);
          Inc(i);
        end
        else
          Result:= Result+Value[i];
      end;

      Inc(i);
    end;
  end;

  procedure DoStrProp;
  var
    Value, NewValue:String;
  begin
    Value:= GetStrProp(Item, PropList[i]);
    NewValue:= Convert(Value);
    if Value<>NewValue then
      SetStrProp(Item, PropList[i], NewValue);
  end;

  procedure DoVariantProp;
  var
    Value:Variant;
  begin
    Value:= GetVariantProp(Item, PropList[i]);
    if (TVarData(Value).VType = varString) or (TVarData(Value).VType = varOleStr) then
    begin
      Value:= Convert(Value);
      SetVariantProp(Item, PropList[i], Value);
    end;
  end;

begin
  TypeInfo:= Item.ClassInfo;
  PropCount:= GetTypeData(TypeInfo).PropCount;
  GetMem(PropList, PropCount * SizeOf(PPropInfo));
  GetPropInfos(TypeInfo, PropList);

  try
    for i:= 0 to PropCount-1 do
    begin
      case PropList[i].PropType^.Kind of
        tkString, tkLString, tkWString:
          DoStrProp;

        tkVariant:
          DoVariantProp;
      end;
    end;

  finally
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  end;
end;

procedure frxWriteCollection(Collection:TCollection; Writer:TWriter;
  Owner:TfrxComponent);
var
  i, l:Integer;
  xs:TfrxXMLSerializer;
  s:String;
  vt:TValueType;
begin
  if Owner.IsWriting then
  begin
    { called from SaveToStream }
    Writer.WriteListBegin;
    xs:= TfrxXMLSerializer.Create(nil);
    try
      xs.Owner:= Owner.Report;
      for i:= 0 to Collection.Count-1 do
      begin
        Writer.WriteListBegin;
        s:= xs.ObjToXML(Collection.Items[i]);
        vt:= vaLString;
        Writer.Write(vt, SizeOf(vt));
        l:= Length(s);
        Writer.Write(l, SizeOf(l));
        Writer.Write(s[1], l);
        Writer.WriteListEnd;
      end;
    finally
      Writer.WriteListEnd;
      xs.Free;
    end;
  end
  else
  begin
    { called from Delphi streamer }
    Writer.WriteCollection(Collection);
  end;
end;

procedure frxReadCollection(Collection:TCollection; Reader:TReader;
  Owner:TfrxComponent);
var
  i:Integer;
  vt:TValueType;
  xs:TfrxXMLSerializer;
  s:String;
  Item:TCollectionItem;
  NeedFree:Boolean;
begin
  vt:= Reader.ReadValue;
  if vt<>vaCollection then
  begin
    { called from LoadFromStream }
    NeedFree:= False;
    xs:= nil;
    if Owner.Report<>nil then
      xs:= TfrxXMLSerializer(Owner.Report.XMLSerializer);

    if xs = nil then
    begin
      xs:= TfrxXMLSerializer.Create(nil);
      xs.Owner:= Owner.Report;
      NeedFree:= True;
    end;

    try
      Collection.Clear;

      while not Reader.EndOfList do
      begin
        Reader.ReadListBegin;
        Item:= Collection.Add;
        s:= Reader.ReadString;
        if NeedFree then
          xs.ReadPersistentStr(Owner.Report, Item, s)
        else
          xs.XMLToObj(s, Item);
        Reader.ReadListEnd;
      end;
    finally
      Reader.ReadListEnd;
      if NeedFree then
        xs.Free;
    end;
  end
  else
  begin
    { called from Delphi streamer }
    Reader.ReadCollection(Collection);
    for i:= 0 to Collection.Count-1 do
      ConvertOneItem(Collection.Items[i], False);
  end;
end;

function frxCreateTempFile(const TempDir:String):String;
var
  Path:String[255];
  FileName:String[255];
begin
  Path:= TempDir;
  if Path = '' then
    Path[0]:= Chr(GetTempPath(64, @Path[1])) else
    Path:= Path+#0;
  if (Path<>'') and (Path[Length(Path)]<>'\') then
    Path:= Path+'\';

  GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
  Result:= StrPas(@FileName[1]);
end;

end.