fmtbcd.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

begin
  VarClear(ADest);
  TFMTBcdVarData(ADest).VType := FMTBcdVariantType.VarType;
  TFMTBcdVarData(ADest).VBcd := TFMTBcdData.Create(ABcd);
end;

function VarFMTBcdCreate: Variant; overload;
begin
  VarFMTBcdCreate(Result, NullBcd);
end;

function VarFMTBcdCreate(const ABcd: TBcd): Variant;
begin
  VarFMTBcdCreate(Result, ABcd);
end;

function VarIsFMTBcd(const AValue: Variant): Boolean;
begin
  Result := (TVarData(AValue).VType = FMTBcdVariantType.VarType);
end;

function VarFMTBcd: TVarType;
begin
  Result := FMTBcdVariantType.VarType;
end;

function StrToBcd(const AValue: string): TBcd;
var
  Success: Boolean;
begin
  Success := TryStrToBcd(AValue, Result);
  if not Success then
    BcdErrorFmt(SInvalidBcdValue, AValue);
end;

procedure DoubleToBcd(const AValue: Double; var bcd: TBcd); overload;
begin
  bcd := StrToBcd(FloatToStr(AValue));
end;
function DoubleToBcd(const AValue: Double): TBcd; overload;
begin
  DoubleToBcd(AValue, Result);
end;

function VarToBcd(const AValue: Variant): TBcd;
begin
  if VarType(AValue) = FMTBcdVariantType.VarType then
    Result := TFMTBcdVarData(AValue).VBcd.FBcd
  else
    Result := TFMTBcdVarData(VarFmtBcdCreate(AValue)).VBcd.FBcd;
end;

function IntegerToBcd( const AValue: Integer): TBcd;
begin
  Result := StrToBcd(IntToStr(AValue));
end;

function BcdToDouble(const Bcd: TBcd): Double;
begin
  Result := StrToFloat(BcdToStr(Bcd));
end;

function BcdToInteger(const Bcd: TBcd; Truncate: Boolean = False): Integer;
var
  ABcd: TBcd;
begin
  if (Truncate) and (BcdScale(Bcd) > 0 ) then
    NormalizeBcd(Bcd,ABcd,Bcd.Precision,0)
  else
    ABcd := Bcd;
  Result := StrToInt(BcdToStr(ABcd));    
end;

{ utility routines }

function RoundAt(const Value: string; Position: SmallInt): string;
var
  P, PP: PChar;
  DecPos: SmallInt;
  Dot : Char;
begin
  Dot := DecimalSeparator;
  DecPos := Pos(Dot, Value);
  if DecPos = 0 then DecPos := Length(Value)
  else Inc(Position, DecPos);
  if (Position < Length(Value)) and (DecPos < Position) then
  begin
    PP := PChar(Value) + ((Position -1));
    P := PP+1;
    if Byte(P^) >= 53  then    { if '5' or greater }
      PP^ := Char(Byte(PP^)+1);
    while (Position > 0) and ((Byte(PP^) > 57) or (PP^ = Dot)) do  {if greater than '9' then }
    begin
      if PP^ <> Dot then
        PP^ := '0';
      Dec(Position);
      Dec(PP);
      if PP^ <> Dot then
        PP^ := Char(Byte(PP^)+1);
    end;
    if Byte(PP^) > 57 then
    begin
      PP^ := '0';
      Result := '1' + Copy(Value,1,Position -1);
    end else
      Result := Copy(Value,1,Position);
  end else
    Result := Value;
end;

function LeftTrim(const Value: string): string;
begin
  Result := Value;
  while (Length(Result) > 1) and (Result[1] = '0') do
    Result := Copy(Result, 2, Length(Result) -1);
end;

function CompareDigits(S1, S2: string): Integer;
begin
  S1 := LeftTrim(S1);
  if Length(S1) > Length(S2) then
    Result := 1
  else if Length(S2) > Length(S1) then
    Result := -1
  else
    Result := CompareStr(S1, S2);
end;

procedure GetValueAndMultiplyOrder(A, B: string; var V, M: string; LA, LB: Integer; var Wid, Len, DecPos: Integer);
var
  DecimalPosA, DecimalPosB: Integer;
  Dot : Char;
begin
  Dot := DecimalSeparator;
  DecPos := 0;
  if CompareDigits(A,B) > 1 then
  begin
    V := A;
    M := B;
    Wid := LA;
    Len := LB;
  end else
  begin
    M := A;
    V := B;
    Wid := LB;
    Len := LA;
  end;  
  { to get rid of GetDecimalPosition }
  DecimalPosA := Pos(Dot, V);
  DecimalPosB := Pos(Dot, M);
  if (DecimalPosA = 0) and (DecimalPosB = 0) then
    DecPos := _NoDecimal
  else
  begin
    if DecimalPosA > 0 then
    begin
      V := StringReplace(V, Dot, '', []);
      DecPos := Wid - DecimalPosA;
      Dec(Wid);
    end;
    if DecimalPosB > 0 then
    begin
      M := StringReplace(M, Dot,'',[]);
      DecPos := DecPos + (Len - DecimalPosB);
      Dec(Len);
    end;
  end;
end;

function AddChars(V, M: Char; var R: Byte): string;
var
  Value: Byte;
begin
  Value := Byte((Byte(V)-48) + (Byte(M)-48) + R);
  if Value > 9 then
  begin
    Result := Char((Value - 10) + 48);
    R := Byte(1);
  end else
  begin
    Result :=  Char(Value + 48);
    R := Byte(0);
  end;
  if Result = '' then Result := '0';
end;

function SubtractChars(V, M: Char; var R: Byte): string;
var
  Value: Byte;
begin
  Value := Byte((Byte(V)-48) - ((Byte(M)-48) + R));
  if Value > 9 then  // Byte is unsigned: values will be between 246-255
  begin
    Result := Char((Value + 10) + 48);
    R := Byte(1);
  end else
  begin
    Result :=  Char(Value + 48);
    R := Byte(0);
  end;
end;

function AddStrings(const V, M: string): string;
var
  Digit: string;
  pV, pM: PChar;     // pointer to string A, string B;
  LenV, LenM, MaxDigits, I, DigitV, DigitM: Integer;
  R: Byte;           // Remainder
  CV, CM: Char;      // char from string A, string B
begin
  if (V = '') or (V = '0') then
  begin
    Result := M;
    Exit;
  end;
  if (M = '') or (M = '0') then
  begin
    Result := V;
    Exit;
  end;
  R := 0;
  pV := PChar(V);
  pM := PChar(M);
  LenV := Length(V);
  LenM := Length(M);
  MaxDigits := Max(LenV, LenM);
  Result := '';
  for I := 1 to MaxDigits do
  begin
    DigitV := LenV - I;
    DigitM := LenM - I;
    if I <= LenV then CV := pV[DigitV] else CV := '0';
    if I <= LenM then CM := pM[DigitM] else CM := '0';
    Digit := AddChars(CV, CM, R);
    Result := Digit + Result;
  end;
  if R > 0 then
    Result := '1' + Result;
end;

function SubtractStrings(const Value, Minus: string): string;
var
  Digit, V, M: string;
  pV, pM: PChar;     // pointer to string A, string B;
  LenV, LenM, MaxDigits, I, DigitV, DigitM: Integer;
  R: Byte;           // Remainder
  CV, CM: Char;      // char from string A, string B
begin
  if CompareDigits(Value, Minus) >= 0 then
  begin
    V := Value;
    M := Minus;
    Result := '';
  end else
  begin
    M := Value;
    V := Minus;
    Result := '-';
  end;
  if (V = '') or (M = '') then
  begin
    if V = '' then Result := '-' + M else Result := V;
  end;
  if (V = '0') or (M = '0') then
  begin
    if M = '0' then
      Result := V
    else if V = '0' then
      Result := '0'
    else
      Result := M;
    Exit;
  end;
  R := 0;
  pV := PChar(V);
  pM := PChar(M);
  LenV := Length(V);
  LenM := Length(M);
  MaxDigits := Max(LenV, LenM);
  Result := '';
  for I := 1 to MaxDigits do
  begin
    DigitV := LenV - I;
    DigitM := LenM - I;
    if I <= LenV then CV := pV[DigitV] else CV := '0';
    if I <= LenM then CM := pM[DigitM] else CM := '0';
    Digit := SubtractChars(CV, CM, R);
    Result := Digit + Result;
  end;
  if Result = '' then Result := '0';
end;

function _ShortMultiply(const A, B: string): string;
var
  DecPos,W,L,I: Integer;
  S, SS, Times: LongWord;
  pMultiplier: PChar;
  Value, Multiplier: string;
  Dot : Char;
begin
  Dot := DecimalSeparator;
  GetValueAndMultiplyOrder(A, B, Value, Multiplier, Length(A), Length(B), W, L, DecPos);
  PMultiplier := PChar(Multiplier);
  Times := 1;
  S := 0;
  for I := L - 1 downto 0 do
  begin
    SS := LongWord(LongWord((Byte(PMultiplier[I])-Byte(48))) * LongWord(StrToInt(Value)) * Times);
    S := SS + S;
    Times := Times * 10;
  end;
  Result := IntToStr(S);
  if DecPos <> _NoDecimal then
  begin
    I := Length(Result) - DecPos;
    if I = 0 then
      Result := '0' + Dot + Result
    else if I > 0 then
      Result := Copy(Result,1, I) + Dot + Copy(Result,I+1,DecPos)
    else if I < 0 then
      Result := Dot + StringOfChar('0', -I) + Result;
  end;
end;

function StringMultiplyByByte(const Value: string; B: Byte): string; pascal;
var
  L : SmallInt;
  PValue, PResult: PChar;
begin
  L := Length(Value);
  PValue := PChar(Value) + (L - 1);   // point to end of input string
  SetLength(Result, L + 1);          // allocate, perhaps 1 more byte than needed.
  PResult := PChar(Result) + L;
  asm
       PUSH          ECX
       PUSH          EDI
       PUSH          ESI
       PUSH          EBX
       MOV           BH,10             // divisor to get both digits
       MOV           EDI,PResult
       MOV           ESI,PValue
       MOV           CX,L               // Store # of digits in Value to CX
       MOV           DX,0               // DX holds remainder, which comes from AH
@@1:   CMP           CX,0               // any more digits:
       JE            @@2
       MOV           AL,[ESI]           // move digit to AL
       SUB           ESI,1              // decrement pointer
       SUB           AL,'0'             // convert from char digit to #
       MUL           B                  // multiply by B: result goes to AX
       ADD           AX,DX              // Add Remainder from DL
       MOV           DX,0               // set remainder back to 0
       DIV           BH                 // Divide by 10; result goes to AL, remainder to AH
       MOV           DL,AL              // move remainder to DL (DH will always 0 here)
       ADD           AH,'0'             // convert from # to char digit
       MOV           [EDI],AH           // move digit to Result
       SUB           EDI,1              // decrement output pointer
       SUB           CX,1
       JMP           @@1
@@2:   ADD           DL,'0'             // move '0' or remainder to last
       MOV           [EDI],DL           // digit of Result
@@3:   POP           EBX
       POP           ESI
       POP           EDI
       POP           ECX
  end;
  if Result[1] = '0' then
    Result := Copy(Result, 2, Length(Result) -1 );
end;

function _LongMultiply(const A, B: string): string;
const
  MaxSmall = 9;
var
  DecPos, W, L, I: Integer;
  Times, S, SS: string;
  pMultiplier: PChar;
  Value, Multiplier: string;
  T1, T2: Integer;
  Dot : Char;
begin
  Dot := DecimalSeparator;
  GetValueAndMultiplyOrder(A, B, Value, Multiplier, Length(A), Length(B), W, L, DecPos);
  T1 := Length(Value);
  T2 := Length(Multiplier);
  pMultiplier := PChar(Multiplier);
  Times := '';
  for I := L-1 downto 0 do
  begin
    if W < MaxSmall then
      SS := IntToStr(LongWord((Byte(PMultiplier[I])-48) * StrToInt(Value))) + Times
    else
      SS := StringMultiplyByByte(Value,Byte(PMultiplier[I])-48) + Times;
    S := AddStrings(SS,S);
    Times := Times + '0';
  end;
  Result := S;
  while Result[1] = '0' do
    Result := Copy(Result, 2, Length(Result) -1);
  if DecPos <> _NoDecimal then
  begin
    I := Length(Result) - DecPos;
    if I = 0 then
      Result := '0' + Dot + Result
    else if I > 0 then
      Result := Copy(Result,1, I) + Dot + Copy(Result,I+1,DecPos)
    else if I < 0 then
      Result := Dot + StringOfChar('0', -I) + Result;
    if T1 + T2 > 1024 then Result := ''  
  end;
end;

// Go through 2 strings and determine if total length > MaxDigits
function CanUseShort(A, B: PChar; MaxDigits: ShortInt): Boolean; pascal;
var
  Dot: Char;
begin
  Dot := DecimalSeparator;
  asm
      PUSH      EAX
      PUSH      EBX
      PUSH      ECX
      PUSH      EDX
      PUSH      EDI
      MOV       EDI,A
      MOV       Result,False
      MOV       CL,0               // Flag for A/B
      MOV       CH,0               // Total Digit counter
      MOV       AH,MaxDigits       // Max Integer Digits
      MOV       DL,0               // Flag for first char
      MOV       DH,0               // Values of first chars
@@1:  MOV       AL,[EDI]
      ADD       EDI,1
      CMP       DL,0               // if first char
      JNE       @@2                // then
      ADD       DH,AL              // save value to DH
      MOV       DL,1
@@2:  CMP       AL,0
      JE        @@3
      CMP       AL,Dot             // if '.' don't count
      JE        @@1
      ADD       CH,1
      JMP       @@1
@@3:  CMP       CL,0
      JNE       @@4
      MOV       CL,1
      MOV       DL,0
      MOV       EDI,B
      JMP       @@1
@@4:  CMP       DH,107
      JA        @@5
      ADD       AH,1
@@5:  CMP       CH,AH
      JA        @@6               // if CH > then AH (Max), then Result stays False