rpmemo.pas

修改datamemo中报表分页时中文显示乱码问题

    FSize := Value;
  end;  { SetSize }

  procedure TMemoBuf.Insert(BufPos: longint; Text: string);
  var
    Needed: longint;
    NewBuffer: PCharArray;
    I1: integer;
    RPTFItem: TRPTFItem;
  begin { Insert }
  { Check for BufPos out of range }
    if BufPos < 0 then begin
      BufPos := 0; { Insert before first char }
    end else if BufPos > FSize then begin
      BufPos := FSize; { Insert after last char }
    end; { else }

  { Allocate more space in buffer if not enough already }
    Needed := FSize + Length(Text);
    if Needed > FMaxSize then begin { Allocate more space }
      Needed := ((Needed - 1) div FBufferInc + 1) * FBufferInc;
      GetMem(NewBuffer,Needed);
      Move(FBuffer^,NewBuffer^,BufPos);
    end else begin
      NewBuffer := FBuffer;
    end; { else }

  { Adjust RPTF commands }
    if HasRPTF then begin
      for I1 := 1 to FRPTFList.Count do begin
        RPTFItem := TRPTFItem(FRPTFList[I1 - 1]);
        if RPTFItem.Pos >= BufPos then begin { Move position }
          RPTFItem.Pos := RPTFItem.Pos + Length(Text);
        end; { if }
      end; { for }
    end; { if }

  { Move any trailing data to make room for Text}
    Move(FBuffer^[BufPos],NewBuffer^[BufPos + Length(Text)],FSize - BufPos);

  { Insert Text }
    if Text <> '' then begin
      Move(Text[1],NewBuffer^[BufPos],Length(Text));
    end; { if }
    FSize := FSize + Length(Text);

  { Check to see if we created a new buffer or not }
    if NewBuffer <> FBuffer then begin
      FreeMem(FBuffer,FMaxSize);
      FBuffer := NewBuffer;
      FMaxSize := Needed;
    end; { if }
  end;  { Insert }

  procedure TMemoBuf.Append(Text: string);
  begin { Append }
    Insert(FSize,Text);
  end;  { Append }

  procedure TMemoBuf.Delete(BufPos: longint;
                            DelLen: longint);
  var
    I1: integer;
    RPTFItem: TRPTFItem;
  begin { Delete }
  { Adjust RPTF commands }
    if HasRPTF then begin
      ReplaceRPTF := true;
      AddRPTFString(StateToRPTF(GetStateAtPos(BufPos + DelLen)),BufPos + DelLen);
      I1 := 0;
      while I1 < FRPTFList.Count do begin
        Inc(I1);
        RPTFItem := TRPTFItem(FRPTFList[I1 - 1]);
        if RPTFItem.Pos >= BufPos then begin { Move position }
          if RPTFItem.Pos < (BufPos + DelLen) then begin { Delete RPTFItem }
            RPTFItem.Free;
            FRPTFList.Delete(I1 - 1);
            Dec(I1);
          end else begin
            RPTFItem.Pos := RPTFItem.Pos - DelLen;
          end; { else }
        end; { if }
      end; { while }
    end; { if }

    if (BufPos < FSize) and (BufPos >= 0) then begin
      if DelLen >= (FSize - BufPos) then begin { Take off end only }
        FSize := BufPos;
      end else begin
        Move(FBuffer^[BufPos + DelLen],FBuffer^[BufPos],FSize - (BufPos + DelLen));
        FSize := FSize - DelLen;
      end; { else }
    end; { if }
  end;  { Delete }

  function TMemoBuf.SearchFirst(SearchText: string; CaseMatters: boolean): boolean;
  var
    SavePos: longint;
  begin { SearchFirst }
    SavePos := Pos;
    FSearchText := SearchText;
    FCaseMatters := CaseMatters;
    if not FCaseMatters then begin
      FSearchText := AnsiUpperCase(FSearchText);
    end; { if }
    FSearchLen := Length(FSearchText);

    Pos := -1;
    Result := SearchNext;
    if not Result then begin { None found, restore position }
      Pos := SavePos;
    end; { if }
  end;  { SearchFirst }

  function TMemoBuf.SearchNext: boolean;
  var
    Start: longint;
    Finish: longint;
    I1: longint;
    I2: longint;
    MainPtr: PChar;
    BufPtr: PChar;
    Found: boolean;
    Ch: char;
  begin { SearchNext }
  { Scan through buffer looking for SearchText }
    Result := false;
    Start := Pos + 1;
    Finish := FSize - FSearchLen;
    MainPtr := @FBuffer^[Start];
    for I1 := Start to Finish do begin
      BufPtr := MainPtr;
      Found := true;
      for I2 := 1 to FSearchLen do begin
        if FCaseMatters then begin
          if BufPtr^ <> FSearchText[I2] then begin
            Found := false;
            Break;
          end; { if }
        end else begin
          Ch := BufPtr^;
          if AnsiUpperCase(Ch) <> FSearchText[I2] then begin
            Found := false;
            Break;
          end; { if }
        end; { else }
        Inc(BufPtr);
      end; { for }
      if Found then begin
        Pos := I1;
        Result := true;
        Break;
      end; { if }
      Inc(MainPtr);
    end; { for }
  end;  { SearchNext }

  procedure TMemoBuf.ReplaceAll(SearchText: string;
                                ReplaceText: string;
                                CaseMatters: boolean);
  var
    Found: boolean;
    SavePos: longint;
    SaveRPTF: string;
  begin { ReplaceAll }
    SavePos := Pos;
    Found := SearchFirst(SearchText,CaseMatters);
    if HasRPTF then begin
      while Found do begin
        SaveRPTF := StateToRPTF(GetStateAtPos(Pos));
        Delete(Pos,Length(SearchText));
        Insert(Pos,ReplaceText);
        ReplaceRPTF := true;
        AddRPTFString(SaveRPTF,Pos);
        Pos := Pos + Length(ReplaceText) - 1;
        Found := SearchNext;
      end; { while }
    end else begin
      while Found do begin
        Delete(Pos,Length(SearchText));
        Insert(Pos,ReplaceText);
        Pos := Pos + Length(ReplaceText) - 1;
        Found := SearchNext;
      end; { while }
    end; { else }
    if SavePos > Size then begin
      Pos := Size;
    end else begin
      Pos := SavePos;
    end; { if }
  end;  { ReplaceAll }

  procedure TMemoBuf.SaveBuffer;
  begin { SaveBuffer }
    FreeSaved;
    FSaveSize := FSize;
    GetMem(FSaveBuffer,FSaveSize);
    Move(FBuffer^,FSaveBuffer^,FSaveSize);
    CopyRPTFList(FRPTFList,FSaveRPTFList);
  end;  { SaveBuffer }

  procedure TMemoBuf.RestoreBuffer;
  begin { RestoreBuffer }
    if Assigned(FSaveBuffer) then begin
      MaxSize := FSaveSize;
      Move(FSaveBuffer^,FBuffer^,FSaveSize);
      FSize := FSaveSize;
      CopyRPTFList(FSaveRPTFList,FRPTFList);
      Reset;
    end; { if }
  end;  { RestoreBuffer }

  procedure TMemoBuf.FreeSaved;
  begin { FreeSaved }
    if Assigned(FSaveBuffer) then begin
      FreeMem(FSaveBuffer,FSaveSize);
      ClearRPTFList(FSaveRPTFList);
      FSaveBuffer := nil;
      FSaveSize := 0;
    end; { if }
  end;  { FreeSaved }

  function TMemoBuf.GetNextLine(var Eol: boolean): string;
  var
    MaxWidth: longint;
  begin { GetNextLine }
    if BaseReport = nil then begin
      RaiseError(Trans('TMemoBuf.BaseReport not assigned.'));
    end; { if }
    with BaseReport do begin
    { Get a single line from MemoBuf }
      MaxWidth := XU2D(PrintEnd) - XU2D(PrintStart) + 1;
      SelectRPFont;
      Result := GetLine(MaxWidth,EOL);
      SelectCanvasFont;
    end; { with }
  end;  { GetNextLine }

  function TMemoBuf.MemoLinesLeft: longint;
  var
    MaxWidth: longint;
    EOL: boolean;
    Line: string;
  begin { MemoLinesLeft }
    if BaseReport = nil then begin
      RaiseError(Trans('TMemoBuf.BaseReport not assigned.'));
    end; { if }
    with BaseReport do begin
    { Process MemoBuf to figure out how many lines are needed to print }
      Result := 0;
      MaxWidth := XU2D(PrintEnd) - XU2D(PrintStart) + 1;
      SaveState;
      SelectRPFont;
      while Pos < Size do begin
        Line := GetLine(MaxWidth,EOL);
        Inc(Result);
      end; { while }
      SelectCanvasFont;
      RestoreState;
    end; { with }
  end;  { MemoLinesLeft }

  function TMemoBuf.PrintLines(Lines: longint; PrintTabs: boolean): double;
  var
    TempTab: PTab;
    TabStr: string[60];
    OnLine: integer;
    MaxWidth: longint;
    Line: string;
    EOL: boolean;
    ThisJustify: TPrintJustify;
    RPTFFontHeight: double;
    CheckHeight: boolean;
  begin { PrintLines }
    Result := 0.0;
    if Lines < 0 then Exit; { Don't print anything }
    if BaseReport = nil then begin
      RaiseError(Trans('TMemoBuf.BaseReport not assigned.'));
    end; { if }

    with BaseReport do begin
      TabStr := '';
      if PrintTabs then begin { Determine how many tab setting there are }
        TempTab := GetTab(1);
        while Assigned(TempTab) do begin
          TabStr := TabStr + #9;
          TempTab := TempTab^.Next;
        end; { while }
      end; { if }

      if PrintEnd <= PrintStart then begin
        RaiseError(Trans('TMemoBuf.PrintEnd must be greater than TMemoBuf.PrintStart'));
      end; { if }
      MaxWidth := XU2D(PrintEnd) - XU2D(PrintStart) + 1;
      CheckHeight := (FMaxHeight > 0.0);
      OnLine := 0;

    { Print the memo lines }
      while ((Lines > 0) and (OnLine < Lines)) or ((Lines = 0) and (Pos < Size)) do begin

      { Get next memo line }
        SaveState;
        SelectRPFont;
        Line := GetLine(MaxWidth,EOL);
        SelectCanvasFont;

      { Determine if there is enough height left }
        if HasRPTF and (LineHeightMethod = lhmFont) then begin
          RPTFFontHeight := RPTFTextHeight(BaseReport,Line);
          if CheckHeight then begin
            FMaxHeight := FMaxHeight - (RPTFFontHeight * 1.2);
            if (FMaxHeight + 0.001) < 0.0 then begin { Not enough height left }
              RestoreState;
              Break;
            end; { if }
          end; { if }

        { Setup line }
          if OnLine > 0 then begin
            if NewParagraph or HardLines then begin
              NewLine;
            end else begin
              SoftLine;
            end; { else }
          end; { if }

          FontHeight := RPTFFontHeight;
          Result := Result + RPTFFontHeight;
          AdjustLine;
        end else begin
        { Setup line }
          if OnLine > 0 then begin
            if NewParagraph or HardLines then begin
              NewLine;
            end else begin
              SoftLine;
            end; { else }
          end; { if }
          Result := Result + LineHeight;
        end; { else }
        Inc(OnLine);

      { Print Tab string }
        if TabStr <> '' then begin
          Print(TabStr);
        end; { if }

      { Get justification }
        if HasRPTF then begin
          Justify := GetJustify(Line,Justify);
        end; { if }
        if EOL and (Justify = pjBlock) then begin
          ThisJustify := pjLeft;
        end else begin
          ThisJustify := Justify;
        end; { else }
      { Print the line }
        PrintJustify(Line,XU2I(PrintStart + LeftIndent) + LineStartPos - XU2I(SectionLeft),
         ThisJustify,0,XU2I(PrintEnd - PrintStart - (LeftIndent + RightIndent)));
      end; { while }

      if not NoNewLine then begin { Finish off with NewLine }
        if NewParagraph or HardLines or (Pos >= Size) then begin
          NewLine;
        end else begin
          SoftLine;
        end; { else }
      end; { if }
    end; { with }
  end;  { PrintLines }

  function TMemoBuf.PrintHeight(Height: double; PrintTabs: boolean): double;
  begin { PrintHeight }
    if BaseReport = nil then begin
      RaiseError(Trans('TMemoBuf.BaseReport not assigned.'));
    end; { if }
    with BaseReport do begin
      AdjustLine;
      if HasRPTF then begin
      { Print lines up to Height }
        FMaxHeight := Height;
        Result := PrintLines(0,PrintTabs);
        FMaxHeight := 0.0;
      end else begin
        FMaxHeight := 0.0;
        Result := PrintLines(Trunc(0.00001 + (Height / LineHeight)),PrintTabs);
      end; { else }
    end; { with }
  end;  { PrintHeight }

  function TMemoBuf.MemoHeightLeft: double;
  begin { MemoHeightLeft }
    Result := ConstrainHeightLeft(99999999.0);
  end;  { MemoHeightLeft }

  function TMemoBuf.ConstrainHeightLeft(Constraint: double): double;
  var
    MaxWidth: longint;
    EOL: boolean;
    Line: string;
    F1: double;
  begin { ConstrainHeightLeft }
    if BaseReport = nil then begin
      RaiseError(Trans('TMemoBuf.BaseReport not assigned.'));
    end; { if }
    with BaseReport do begin
      if HasRPTF and (LineHeightMethod = lhmFont) then begin
      { Process MemoBuf to figure out how many lines are needed to print }
        Result := 0.0;
        MaxWidth := XU2D(PrintEnd) - XU2D(PrintStart) + 1;
        SaveState;
        SelectRPFont;
        while Pos < Size do begin
          Line := GetLine(MaxWidth,EOL);
          F1 := RPTFTextHeight(BaseReport,Line);
          F1 := F1 * 1.2;
          if (Result + F1) <= Constraint then begin
            Result := Result + F1;
          end else begin
            Break; { Reached constraint height }
          end; { else }
        end; { while }
        SelectCanvasFont;
        RestoreState;
      end else begin
        Result := MemoLinesLeft * LineHeight;
        if Result > Constraint then begin
          Result := Int(Constraint / LineHeight) * LineHeight;
        end; { if }
      end; { else }
    end; { with }
  end;  { ConstrainHeightLeft }

end.