jvgreport.pas

East make Tray Icon in delphi

    BeforePrint(Self);
  OwnerWnd := TForm.Create(nil);
  TForm(OwnerWnd).WindowState := wsMaximized;
  ParentWnd := OwnerWnd;
  //OwnerWnd.Show;
  try
    CreateReport(ParentWnd, True);
    if ComponentList.Count = 0 then
      Exit;

    Printer.BeginDoc;
    ScreenDC := GetDC(HWND_DESKTOP);

    HS := CentimetersToPixels(ScreenDC, 21, True);
    WS := CentimetersToPixels(ScreenDC, 21, False);
    HP := CentimetersToPixels(Printer.Canvas.Handle, 21, True);
    WP := CentimetersToPixels(Printer.Canvas.Handle, 21, False);

    ReleaseDC(HWND_DESKTOP, ScreenDC);

    for I := 0 to ComponentList.Count - 1 do
    begin
      TJvgReportItem(ComponentList[I]).Left :=
        MulDiv(TJvgReportItem(ComponentList[I]).Left, WP, WS);
      TJvgReportItem(ComponentList[I]).Top :=
        MulDiv(TJvgReportItem(ComponentList[I]).Top, HP, HS);
      TJvgReportItem(ComponentList[I]).Width :=
        MulDiv(TJvgReportItem(ComponentList[I]).Width, WP, WS);
      TJvgReportItem(ComponentList[I]).Height :=
        MulDiv(TJvgReportItem(ComponentList[I]).Height, HP, HS);
      TJvgReportItem(ComponentList[I]).PenWidth :=
        MulDiv(TJvgReportItem(ComponentList[I]).PenWidth, HP, HS);
    end;

    for I := 0 to ComponentList.Count - 1 do
      with TJvgReportItem(ComponentList[I]) do
      begin
        PaintTo(Printer.Canvas);
        if ContainOLE then
          OLEContainer.PaintTo(Printer.Canvas.Handle, Left, Top);
      end;
    Printer.EndDoc;

    repeat Application.ProcessMessages;
    until not TForm(OwnerWnd).Active;
  finally
    OwnerWnd.Free;
  end;
end;

procedure TJvgReport.ClearReport;
var
  I: Integer;
begin
  for I := 0 to ComponentList.Count - 1 do
    TJvgReportItem(ComponentList[I]).Free;
  ComponentList.Count := 0;
end;

procedure TJvgReport.CreateReport(ParentWnd: TWinControl; fNeedClearOwner:
  Boolean);
var
  ms: TMemoryStream;
  P: TParser;
  c: Char;
  Compon: TComponent;
  sName, sClassName: string;
  S1, S2: string;

  procedure N2T;
  begin
    P.NextToken;
    P.NextToken;
  end;

  procedure Create_Object(const sClassName, sName: string);
  var
    B: TJvgReportItem;
  begin
    B := nil;
    if sClassName = 'TJvgReportItem' then //...process only TJvgReportItem class
    begin
      B := TJvgReportItem.Create(OwnerWnd);
      B.Report := Self;
    end;
    if B = nil then
      Exit;
    ComponentList.Add(B);
    c := P.NextToken;
    while not P.TokenSymbolIs('end') do
      with P do
      begin
        case c of
          '+':
            begin
              P.NextToken;
              B.Text := B.Text + TokenString;
            end;
          toSymbol:
            begin
              if TokenString = 'Left' then
              begin
                N2T;
                B.Left := TokenInt;
              end;
              if TokenString = 'Top' then
              begin
                N2T;
                B.Top := TokenInt;
              end;
              if TokenString = 'Width' then
              begin
                N2T;
                B.Width := TokenInt;
              end;
              if TokenString = 'Height' then
              begin
                N2T;
                B.Height := TokenInt;
              end;
              if TokenString = 'Text' then
              begin
                N2T;
                B.Text := TokenString;
              end;
              if TokenString = 'BkColor' then
              begin
                N2T;
                B.BkColor := TokenInt;
              end;
              if TokenString = 'BvColor' then
              begin
                N2T;
                B.BvColor := TokenInt;
              end;
              if TokenString = 'Transparent' then
              begin
                N2T;
                B.Transparent := TokenInt;
              end;
              if TokenString = 'Alignment' then
              begin
                N2T;
                B.Alignment := TokenInt;
              end;
              if TokenString = 'SideLeft' then
              begin
                N2T;
                B.SideLeft := TokenInt;
              end;
              if TokenString = 'SideTop' then
              begin
                N2T;
                B.SideTop := TokenInt;
              end;
              if TokenString = 'SideRight' then
              begin
                N2T;
                B.SideRight := TokenInt;
              end;
              if TokenString = 'SideBottom' then
              begin
                N2T;
                B.SideBottom := TokenInt;
              end;
              if TokenString = 'PenStyle' then
              begin
                N2T;
                B.PenStyle := TokenInt;
              end;
              if TokenString = 'PenWidth' then
              begin
                N2T;
                B.PenWidth := TokenInt;
              end;
              if TokenString = 'CompName' then
              begin
                N2T;
                B.CompName := TokenString;
              end;
              if TokenString = 'FName' then
              begin
                N2T;
                B.FName := TokenString;
              end;
              if TokenString = 'FSize' then
              begin
                N2T;
                B.FSize := TokenInt;
              end;
              if TokenString = 'FColor' then
              begin
                N2T;
                B.FColor := TokenInt;
              end;
              if TokenString = 'FStyle' then
              begin
                N2T;
                B.FStyle := TokenInt;
              end;
              if TokenString = 'OLELinkToFile' then
              begin
                N2T;
                B.OLELinkToFile := TokenString;
              end;
              if TokenString = 'OLESizeMode' then
              begin
                N2T;
                B.OLESizeMode := TokenInt;
              end;
              if TokenString = 'Fixed' then
              begin
                N2T;
                B.Fixed := TokenInt;
              end;
            end;
        end;
        c := NextToken;
      end;

    B.Parent := ParentWnd;
    try
      B.ContainOLE := B.OLELinkToFile <> '';
    except
      S1 := RsOLELinkedObjectNotFound;
      S2 := RsErrorText;
      Application.MessageBox(PChar(S1), PChar(S2),
        MB_APPLMODAL or MB_OK or MB_ICONSTOP);
    end;
    B.Name := sName;
    if B.CompName = '' then
      SetUnicalName(B);
    AnalyzeParams(B, B.CompName);
  end;

  procedure ClearOwner;
  var
    I: Integer;
  begin
    //    ParamNames.Clear;
    //    ParamMasks.Clear;
    //    ParamValues.Clear;
    //    ParamTypes.Clear;
    ComponentList.Clear;
    if Assigned(ParentWnd) then
    begin
      with ParentWnd do
        for I := ControlCount - 1 downto 0 do
          if Controls[I] is TJvgReportItem then
            RemoveControl(Controls[I]);
      with OwnerWnd do
        for I := ComponentCount - 1 downto 0 do
        begin
          if Components[I] is TJvgReportItem then
          begin
            Compon := Components[I];
            RemoveComponent(Compon);
            Compon.Free;
          end;
        end;
    end;
  end;

begin
  ValidateWnds;
  if fNeedClearOwner then
    ClearOwner
  else
    ClearReport;
  ms := TMemoryStream.Create;
  FReportList.SaveToStream(ms);
  ms.Position := 0;
  P := TParser.Create(ms);
  c := P.Token;
  with P do
    repeat
      if TokenSymbolIs('object') then //...only noname objects!
      begin
        NextToken;
        sClassName := TokenString;
        try
          Create_Object(sClassName, sName);
        except
          S1 := RsErrorReadingComponent;
          S2 := RsErrorText;
          Application.MessageBox(PChar(S1), PChar(S2),
            MB_APPLMODAL or MB_OK or MB_ICONSTOP);
        end;
      end;
      c := NextToken;
    until c = toEOF;

  P.Free;
  ms.Free;
end;

function TJvgReport.AddComponent: TJvgReportItem;
begin
  //AnalyzeParams( ReportComponent );
  ValidateWnds;
  Result := TJvgReportItem.Create(OwnerWnd);
  Result.Report := Self;
  SetUnicalName(Result);
  Result.Parent := ParentWnd;
  ComponentList.Add(Result);
end;

procedure TJvgReport.SetUnicalName(laBevel: TJvgReportItem);
var
  I: Integer;

  function ComponentExists(No: Integer): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := 0 to OwnerWnd.ComponentCount - 1 do
      if OwnerWnd.Components[I] is TJvgReportItem then
        if TJvgReportItem(OwnerWnd.Components[I]).CompName = 'Component' +
          IntToStr(No) then
        begin
          Result := True;
          Break;
        end;
  end;
begin
  I := 0;
  repeat
    Inc(I);
  until not ComponentExists(I);
  laBevel.CompName := 'Component' + IntToStr(I);
end;

procedure TJvgReport.AnalyzeParams(Item: TJvgReportItem; const DefName: string);
var
  LastPos: Integer;
  SList: TStringList;
  ParamType: TJvgReportParamKind;
  ParamText, ParamName, ParamMask, ParamValue: string;

  function ExtractParam(Item: TJvgReportItem; var SrchPos: Integer;
    var ParamName: string; var ParamType: TJvgReportParamKind): Boolean;
  var
    I, J: Integer;
    f: Boolean;
    Text: string;
  begin
    Result := False;
    Text := Item.Text;
    if Length(Text) = 0 then
      Exit;
    f := False;
    for I := SrchPos to Length(Text) - 1 do
      if Text[I] = '#' then
      begin
        f := True;
        Break;
      end;

    if not f then
      Exit;
    if Text[I - 1] = '{' then
      ParamType := gptEdit
    else
    if Text[I - 1] = '<' then
      ParamType := gptRadio
    else
    if Text[I - 1] = '[' then
      ParamType := gptCheck
    else
      ParamType := gptUnknown;

    if not f or (ParamType = gptUnknown) then
      Exit;
    SrchPos := I + 1;
    f := False;
    for I := SrchPos to Length(Text) do
      if (Text[I] = '}') or (Text[I] = ']') or (Text[I] = '>') then
      begin
        f := True;
        Break;
      end;
    if not f then
      Exit;
    ParamName := Copy(Text, SrchPos, I - SrchPos);

    J := ParamNames.IndexOf(ParamName);
    if J <> -1 then
      Item.PrintText := Copy(Text, 0, SrchPos - 3) + ParamValues[J] +
        Copy(Text, I + 1, 255);

    Result := True;
  end;

begin
  LastPos := 0;
  SList := TStringList.Create;
  try
    repeat
      if ExtractParam(Item, LastPos, ParamText, ParamType) then
      begin
        ParamMask := '';
        ParamValue := '';
        ParamTypes.Add(Pointer(ParamType));
        if ParamType = gptEdit then
        begin
          if ParamText = '' then
            ParamText := DefName;
          SList.CommaText := ParamText;
          if SList.Count = 0 then
            continue;
          ParamName := SList[0];
          if SList.Count > 1 then
            ParamMask := SList[1];
          if SList.Count > 2 then
            ParamValue := SList[2];
        end
        else
          ParamName := ParamText;
        if ParamNames.IndexOf(ParamName) <> -1 then
          continue; //...already exists
        ParamNames.Add(ParamName);
        ParamMasks.Add(ParamMask);
        ParamValues.Add(ParamValue);
        // else ParamValues[ParamIndex] := sParamValue;
      end
      else
        Break;
    until False;
  finally
    SList.Free;
  end;
end;

function TJvgReport.SetParam(const sParamName, sParamValue: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  I := ParamNames.IndexOf(sParamName);
  if I <> -1 then
  begin
    Result := True;
    ParamValues[I] := sParamValue;
  end;
end;

function TJvgReport.GetParam(const sParamName: string; var sParamValue: string):
  Boolean;
var
  ParamIndex: Integer;
begin
  ParamIndex := ParamNames.IndexOf(sParamName);
  if ParamIndex = -1 then
    Result := False
  else
  begin
    Result := True;
    sParamValue := ParamValues[ParamIndex];
  end;
end;

procedure TJvgReport.ValidateWnds;
begin
  OwnerWnd := ParentWnd;
  //  if (OwnerWnd=nil)or(ParentWnd=nil) then raise Exception.Create('TJvgReport: Unassigned Owner or Parent window.');
end;

function TJvgReport.GetReportText: TStringList;
begin
  Result := FReportList;
end;

procedure TJvgReport.SetReportText(Value: TStringList);
begin
  FReportList.Assign(Value);
end;

{$IFDEF USEJVCL}
{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}
{$ENDIF USEJVCL}

end.