rm_utils.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,252 行 · 第 1/4 页

var
  lStr: AnsiString;
  Arec: char;
  i: integer;
begin
  lStr := '';
  aStream.Position := 0;
  for i := 0 to aStream.Size - 1 do
  begin
    aStream.Read(arec, 1);
    lStr := lStr + HexByte(Ord(Arec));
  end;
  lStr := lStr + '#';
  Result := lStr;
end;

{***************************函数头部说明******************************
// 单元名称 : Unit1
// 函数名称 :TForm1.TXT2File
// 函数实现目标：流转为文件
// 参    数 :inStr:AnsiString;Filename:String
// 返回值   :Boolean
// 作    者 :  ＳＩＮＭＡＸ           　　　　　  　　　　　
// 　　　　 "._`-.　　　　 (\-.　          Http://SinMax.yeah.net ;
// 　　　　　　'-.`;.--.___/ _`>　      　 Email:[e-mail]
// 　　　　　　　 `"( )　　, ) 　      　　　　
// 　　　　　　　　　\\----\-\　       　　　==== 郎  正 ====  　
// 　　　 ~~ ~~~~~~ "" ~~ """ ~~~~~~~~~　　
// 创建日期 :  2002-07-26
// 工作路径 :  D:\报表客户端\计算\
// 修改记录 :
// 备   注 :
********************************************************************}

function RMTXT2Stream(inStr: AnsiString; OutStream: TStream): Boolean;
var
  i, DEC: integer;
  lChar: Char;
begin
  Result := False;
  if inStr = '' then
  begin
    Result := True;
    Exit;
  end;

  i := 1;
  try
    while not (inStr[i] = '#') do
    begin
      DEC := StrtoInt(('$' + inStr[i])) * 16 + StrtoInt('$' + inStr[i + 1]);
      lChar := Chr(dec);
      OutStream.Write(lChar, 1);
      i := i + 2;
    end;
    Result := True;
  except
  end
end;

{$HINTS OFF}

function RMisNumeric(St: string): Boolean;
var
  R: Double;
  E: Integer;
begin
  Val(St, R, E);
  Result := (E = 0);
end;
{$HINTS ON}

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMDeviceCompatibleCanvas }

constructor TRMDeviceCompatibleCanvas.Create(aReferenceDC: HDC; aWidth, aHeight: Integer; aPalette: HPalette);
begin
  inherited Create;

  FReferenceDC := aReferenceDC;
  FWidth := aWidth;
  FHeight := aHeight;

  FSavePalette := 0;
  FRestorePalette := False;

  FCompatibleDC := CreateCompatibleDC(FReferenceDC);

  FCompatibleBitmap := CreateCompatibleBitmap(FReferenceDC, aWidth, aHeight);
  FOldBitMap := SelectObject(FCompatibleDC, FCompatibleBitmap);

  if aPalette <> 0 then
  begin
    FSavePalette := SelectPalette(FCompatibleDC, aPalette, False);
    RealizePalette(FCompatibleDC);
    FRestorePalette := True;
  end
  else
  begin
    FSavePalette := SelectPalette(FCompatibleDC, SystemPalette16, False);
    RealizePalette(FCompatibleDC);
    FRestorePalette := True;
  end;

  PatBlt(FCompatibleDC, 0, 0, aWidth, aHeight, WHITENESS);
  SetMapMode(FCompatibleDC, MM_TEXT);
end;

destructor TRMDeviceCompatibleCanvas.Destroy;
begin
  if FRestorePalette then
    SelectPalette(FReferenceDC, FSavePalette, False);

  FReferenceDC := 0;
  Handle := 0;
  if FCompatibleDC <> 0 then
  begin
    SelectObject(FCompatibleDC, FOldBitMap);
    DeleteObject(FCompatibleBitmap);
    DeleteDC(FCompatibleDC);
  end;

  inherited Destroy;
end;

procedure TRMDeviceCompatibleCanvas.CreateHandle;
begin
  UpdateFont;
  Handle := FCompatibleDC;
end;

procedure TRMDeviceCompatibleCanvas.Changing;
begin
  inherited Changing;
  UpdateFont;
end;

procedure TRMDeviceCompatibleCanvas.UpdateFont;
var
  lFontSize: Integer;
  liDevicePixelsPerInch: Integer;
begin
  liDevicePixelsPerInch := GetDeviceCaps(FReferenceDC, LOGPIXELSY);
  if (liDevicePixelsPerInch <> Font.PixelsPerInch) then
  begin
    lFontSize := Font.Size;
    Font.PixelsPerInch := liDevicePixelsPerInch;
    Font.Size := lFontSize;
  end;
end;

procedure TRMDeviceCompatibleCanvas.RenderToDevice(aDestRect: TRect; aPalette: HPalette; aCopyMode: TCopyMode);
var
  lSavePalette: HPalette;
  lbRestorePalette: Boolean;
begin
  lSavePalette := 0;
  lbRestorePalette := False;
  if aPalette <> 0 then
  begin
    lSavePalette := SelectPalette(FReferenceDC, aPalette, False);
    RealizePalette(FReferenceDC);
    lbRestorePalette := True;
  end;

  BitBlt(FReferenceDC,
    aDestRect.Left, aDestRect.Top, aDestRect.Right - aDestRect.Left, aDestRect.Bottom - aDestRect.Top,
    FCompatibleDC, 0, 0, aCopyMode);

  if lbRestorePalette then
    SelectPalette(FReferenceDC, lSavePalette, False);
end;

// Draw Bitmap

procedure _DrawDIBitmap(aCanvas: TCanvas; const aDestRect: TRect; aBitmap: TBitmap;
  aCopyMode: TCopyMode);
var
  BitmapHeader: pBitmapInfo;
  BitmapImage: Pointer;
  HeaderSize: DWORD;
  ImageSize: DWORD;
begin
  GetDIBSizes(aBitmap.Handle, HeaderSize, ImageSize);
  GetMem(BitmapHeader, HeaderSize);
  GetMem(BitmapImage, ImageSize);
  try
    SetStretchBltMode(aCanvas.Handle, STRETCH_DELETESCANS);
    GetDIB(aBitmap.Handle, aBitmap.Palette, BitmapHeader^, BitmapImage^);
    StretchDIBits(aCanvas.Handle, aDestRect.Left, aDestRect.Top,
      aDestRect.Right - aDestRect.Left, aDestRect.Bottom - aDestRect.Top,
      0, 0, aBitmap.Width, aBitmap.Height, BitmapImage, TBitmapInfo(BitmapHeader^),
      DIB_RGB_COLORS, aCopyMode);
  finally
    FreeMem(BitmapImage);
    FreeMem(BitmapHeader);
  end;
end;

procedure _DrawTransparentDIBitmap(aCanvas: TCanvas; const aDestRect: TRect; aBitmap: TBitmap;
  aCopyMode: TCopyMode);
var
  liRasterCaps: Integer;
  lbStretchBlt: Boolean;

  function ppTransparentStretchBlt(aDstDC: HDC; aDstX, aDstY, aDstW, aDstH: Integer;
    aSrcDC: HDC; aSrcX, aSrcY, aSrcW, aSrcH: Integer; aMaskDC: HDC; aMaskX, aMaskY: Integer): Boolean;

  var
    lMemDC: HDC;
    lMemBmp: HBITMAP;
    lSaveBmp: HBITMAP;
    lSavePal: HPALETTE;
    lSaveTextColor, lSaveBkColor: TColorRef;

  begin

    Result := True;

    lSavePal := 0;

    {create compatible device context}
    lMemDC := CreateCompatibleDC(aSrcDC);

    try

      {create compatible bitmap and select into compatible DC}
      lMemBmp := CreateCompatibleBitmap(aSrcDC, aSrcW, aSrcH);
      lSaveBmp := SelectObject(lMemDC, lMemBmp);

      {get the current palette}
      lSavePal := SelectPalette(aSrcDC, SystemPalette16, False);

      SelectPalette(aSrcDC, lSavePal, False);

      {initialize memDC with appropriate palette}
      if lSavePal <> 0 then
        lSavePal := SelectPalette(lMemDC, lSavePal, True)
      else
        lSavePal := SelectPalette(lMemDC, SystemPalette16, True);

      RealizePalette(lMemDC);

      {copy the mask to the memDC and then copy the source using SrcErase }
      StretchBlt(lMemDC, 0, 0, aSrcW, aSrcH, aMaskDC, aMaskX, aMaskY, aSrcW, aSrcH, SrcCopy);
      StretchBlt(lMemDC, 0, 0, aSrcW, aSrcH, aSrcDC, aSrcX, aSrcY, aSrcW, aSrcH, SrcErase);

      {set text and background color for destination DC}
      lSaveTextColor := SetTextColor(aDstDC, $0);
      lSaveBkColor := SetBkColor(aDstDC, $FFFFFF);

      {copy mask to destDC and then copy the MemDC using SrcInvert}
      StretchBlt(aDstDC, aDstX, aDstY, aDstW, aDstH, aMaskDC, aMaskX, aMaskY, aSrcW, aSrcH, SrcAnd);
      StretchBlt(aDstDC, aDstX, aDstY, aDstW, aDstH, lMemDC, 0, 0, aSrcW, aSrcH, SrcInvert);

      {restore the text and background colors}
      SetTextColor(aDstDC, lSaveTextColor);
      SetBkColor(aDstDC, lSaveBkColor);

      {restore the mem bmp}
      if lSaveBmp <> 0 then
        SelectObject(lMemDC, lSaveBmp);

      {delete the memDbmp}
      DeleteObject(lMemBmp);

    finally

      {restore the palette and delete the memDC}
      if lSavePal <> 0 then
        SelectPalette(lMemDC, lSavePal, False);
      DeleteDC(lMemDC);

    end;

  end;

  procedure ppDrawTransparentDIBitmapUsingStretchBlt(aCanvas: TCanvas; const aRect: TRect; aBitmap: TBitmap; aCopyMode: TCopyMode);
  var
    liDrawWidth: Integer;
    liDrawHeight: Integer;
    liBitmapWidth: Integer;
    liBitmapHeight: Integer;
    lMaskBmp: TBitmap;
    lMaskCanvas: TRMDeviceCompatibleCanvas;
    lMemCanvas: TRMDeviceCompatibleCanvas;
    liDeviceBPP: Integer;
  begin

    liDrawWidth := aRect.Right - aRect.Left;
    liDrawHeight := aRect.Bottom - aRect.Top;

    {get device bitmap bits per pixel}
    liDeviceBPP := GetDeviceCaps(aCanvas.Handle, BITSPIXEL) * GetDeviceCaps(aCanvas.Handle, PLANES);

    {if device is monochrome, size bitmap based on printer pixels,
                              otherwise use screen pixels (to minimize memory}
    if (liDeviceBPP = 1) then
    begin
      liBitmapWidth := aRect.Right - aRect.Left;
      liBitmapHeight := aRect.Bottom - aRect.Top;
    end
    else
    begin
      liBitmapWidth := aBitmap.Width;
      liBitmapHeight := aBitmap.Height;

    end;

    {create a device compatible canvas in memory - with the required dimensions}
    lMemCanvas := TRMDeviceCompatibleCanvas.Create(aCanvas.Handle, liBitmapWidth, liBitmapHeight,
      aBitmap.Palette);

    {draw the bmp to the mem canvas}
    _DrawDIBitmap(lMemCanvas, Rect(0, 0, liBitmapWidth, liBitmapHeight), aBitmap, cmSrcCopy);

    {create a mask bmp}
    lMaskBmp := TBitmap.Create;
    lMaskBmp.Assign(aBitmap);
    lMaskBmp.Mask(clWhite);
    lMaskCanvas := TRMDeviceCompatibleCanvas.Create(aCanvas.Handle, liBitmapWidth,
      liBitmapHeight,
      aBitmap.Palette);

    {draw the mask bmp to the mask mem canvas}
    _DrawDIBitmap(lMaskCanvas, Rect(0, 0, liBitmapWidth, liBitmapHeight), lMaskBmp, cmSrcCopy);

    aCanvas.Brush.Style := bsClear;

    {use mem canvas and mask canvas to draw to the device canvas}
    ppTransparentStretchBlt(aCanvas.Handle, aRect.Left, aRect.Top,
      liDrawWidth, liDrawHeight,
      lMemCanvas.Handle, 0, 0, liBitmapWidth, liBitmapHeight,
      lMaskCanvas.Handle, 0, 0);

    lMaskBmp.Free;
    lMaskCanvas.Free;
    lMemCanvas.Free;
  end;

begin
  liRasterCaps := GetDeviceCaps(aCanvas.Handle, RASTERCAPS);
  lbStretchBlt := (liRasterCaps and RC_STRETCHBLT) > 0;
  if lbStretchBlt then
    ppDrawTransparentDIBitmapUsingStretchBlt(aCanvas, aDestRect, aBitmap, aCopyMode)
  else
    _DrawDIBitmap(aCanvas, aDestRect, aBitmap, aCopyMode);
end;

procedure RMPrintGraphic(aCanvas: TCanvas; aDestRect: TRect; aGraphic: TGraphic;
  aIsPrinting: Boolean; aDirectDraw: Boolean; aTransparent: Boolean);
var
  lBmp: TBitmap;
  liFreeBitmap: Boolean;

  procedure _GetAsBitmap;
  begin
    liFreeBitmap := True;
    lBmp := TBitmap.Create;
    try
      lBmp.Width := aGraphic.Width;
      lBmp.Height := aGraphic.Height;
      lBmp.Palette := aGraphic.Palette;
      lBmp.HandleType := bmDIB;
      lBmp.Canvas.Draw(0, 0, aGraphic);
    except
      try
        lBmp.Width := Trunc(aGraphic.Width * 0.25);
        lBmp.Height := Trunc(aGraphic.Height * 0.25);
        lBmp.Palette := aGraphic.Palette;
        lBmp.HandleType := bmDIB;
        lBmp.Canvas.StretchDraw(Rect(0, 0, lBmp.Width, lBmp.Height), aGraphic);
      except
        lBmp.Free;
        lBmp := nil;
        liFreeBitmap := False;
      end;
    end;
  end;

  procedure _DirectDrawImage(aGraphic: TGraphic);
  begin
    aCanvas.StretchDraw(aDestRect, aGraphic);
  end;

  procedure _DrawGraphic(aGraphic: TGraphic);
  var
    lMemCanvas: TRMDeviceCompatibleCanvas;
    lCopyMode: TCopyMode;
  begin
    lMemCanvas := TRMDeviceCompatibleCanvas.Create(aCanvas.Handle, aDestRect.Right - aDestRect.Left, aDestRect.Bottom - aDestRect.Top, aGraphic.Palette);
    if aGraphic is TBitmap then
      _DrawDIBitmap(lMemCanvas, aDestRect, TBitmap(aGraphic), cmSrcCopy)
    else
      lMemCanvas.StretchDraw(aDestRect, aGraphic);

    if aTransparent then
      lCopyMode := cmSrcAnd
    else
      lCopyMode := cmSrcCopy;

    lMemCanvas.RenderToDevice(aDestRect, aGraphic.Palette, lCopyMode);
    lMemCanvas.Free;
  end;

  procedure _DrawBmp(const aBitmap: TBitmap);
  begin
    if aTransparent then
      _DrawTransparentDIBitmap(aCanvas, aDestRect, aBitmap, cmSrcCopy)
    else
      _DrawDIBitmap(aCanvas, aDestRect, aBitmap, cmSrcCopy);
  end;

begin
  //  Application.ProcessMessages;
  if (not aIsPrinting) or (aGraphic is TMetaFile) or (aGraphic is TIcon) then
  begin
    aCanvas.StretchDraw(aDestRect, aGraphic);
    Exit;
  end;

  lBmp := nil;
  liFreeBitmap := False;
  try
    if aGraphic is TBitmap then
      lBmp := TBitmap(aGraphic)
    else
      _GetAsBitmap;

    if aGraphic is TBitmap then
    begin
      if lBmp.Monochrome and aDirectDraw then
        _DirectDrawImage(aGraphic)
      else
        _DrawBMP(lBmp);
    end
    else if aDirectDraw then
      _DirectDrawImage(aGraphic)
    else if lBmp <> nil then
      _DrawBMP(lBmp)
    else
      _DrawGraphic(aGraphic);
  finally
    if liFreeBitmap then
      lBmp.Free;
  end;
end;

function RMStrGetToken(s: string; delimeter: string; var APos: integer): string;
var
  tempStr: string;
  endStringPos: integer;
begin
  result := '';
  if APos <= 0 then exit;
  if APos > length(s) then
  begin
    APos := -1;
    exit;
  end;

  tempStr := copy(s, APos, length(s) + 1 - APos);
  if (length(delimeter) = 1) then
    {$IFNDEF Delphi3}
    endStringPos := pos(delimeter, tempStr)
      {$ELSE}
    endStringPos := AnsiPos(delimeter, tempStr)
      {$ENDIF}
  else
  begin
    delimeter := ' ' + delimeter + ' ';
    {$IFNDEF Delphi3}
    endStringPos := pos(UpperCase(delimeter), UpperCase(tempStr));
    {$ELSE}
    endStringPos := AnsiPos(UpperCase(delimeter), UpperCase(tempStr));
    {$ENDIF}
  end;

  if endStringPos <= 0 then
  begin
    result := tempStr;
    APos := -1;
  end
  else
  begin
    result := copy(tempStr, 1, endStringPos - 1);
    APos := APos + endStringPos + length(delimeter) - 1;
  end
end;

function RMCmp(const S1, S2: string): Boolean;
begin
  Result := (Length(S1) = Length(S2)) and
    (CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1),
    -1, PChar(S2), -1) = 2);
end;

function RMExtractField(const aStr: string; aFieldNo: Integer): string;
var
  i, j, k: Integer;
begin
  Result := '';
  j := 1;
  k := 0;
  for i := 1 to Length(aStr) do
  begin
    if aStr[i] = #1 then
    begin
      Inc(k);
      if k = aFieldNo then
      begin
        Result := Copy(aStr, j, i - j);
        Break;
      end
      else
        j := i + 1;
    end;
  end;
end;

procedure RMSetNullValue(var aValue1, aValue2: Variant);

  procedure _SetValue(var aValue1: Variant; const aValue2: Variant);
  begin
    if (TVarData(aValue2).VType = varString) or (TVarData(aValue2).VType = varOleStr) then
      aValue1 := ''
    else if TVarData(aValue2).VType = varBoolean then
      aValue1 := False
    else
      aValue1 := 0;
  end;

begin
  if (aValue1 = Null) or (aValue2 = Null) then
  begin
    if aValue1 = Null then
    begin
      _SetValue(aValue1, aValue2);
    end
    else if aValue2 = Null then
    begin
      _SetValue(aValue2, aValue1);
    end;
  end;
end;

function RMDeleteNoNumberChar(s: string): string;
begin
  s := Trim(s);
  while (Length(s) > 0) and not (s[1] in ['-', '0'..'9']) do
    s := Copy(s, 2, 255); // trim all non-digit chars at the begin
  while (Length(s) > 0) and not (s[Length(s)] in ['0'..'9']) do
    s := Copy(s, 1, Length(s) - 1); // trim all non-digit chars at the end
  while Pos(ThousandSeparator, s) <> 0 do
    Delete(s, Pos(ThousandSeparator, s), 1);

  Result := s;
end;

end.