使用Delphi 6使用StretchDIBits处理条形码图像 – 输出中缺少条

我的应用程序是在Delphi 6中开发的.由于后台处理和大量数据,它是一个资源集成应用程序(它消耗大约60MB – 120MB的物理内存).该应用程序的一个功能是在进行某些处理后创建条形码图像.
如果用户继续生成条形码,那么至少十分之一的条形码中缺少一行.
我们在生成输出时有以下步骤：

>在内存中创建条形码图像(TImage).图像的高度为10像素.我们使用pf24bit像素格式.
>根据打印机的画布??调整内存中的图像大小并将其传递到打印机的画布??.
步骤#2的代码如下：

procedure PrintBitmap(ARect:TRect; Bitmap:TBitmap);
var
  Info: PBitmapInfo;
  InfoSize: dword{Integer};
  Image: Pointer;
  ImageSize: dword{ integer};
  iReturn : integer ;
  iWidth,iHeight :integer;
begin
try
  with Bitmap do
  begin
     iReturn := 1;
     GetDIBSizes( Handle,InfoSize,ImageSize );
     GetMem( Info,InfoSize );
     try
        getMem( Image,ImageSize );
        try
           GetDIB(Handle,Palette,Info^,Image^);
           try
             with Info^.bmiHeader do
             begin
                SetStretchBltMode(Printer.Canvas.handle,HALFTONE);
                iReturn := **StretchDIBits**(Printer.Canvas.Handle,ARect.Left,ARect.Top,ARect.Right - ARect.Left,ARect.Bottom - ARect.Top,biWidth,biHeight,Image,DIB_RGB_COLORS,SRCCOPY);
             end;
           except on E:Exception do
           begin
              gobjLog.pWritetoLog(0,'RptWrks2','PrintBitmap','Exception in StretchDIBits with message '+e.Message);
           end;
           end
        finally
           FreeMem(Image,ImageSize);
        end;
     finally
        FreeMem(Info,InfoSize);
     end;
end
except on E:Exception do
begin
    gobjLog.pWritetoLog(0,'Exception in PrintBitMap with message '+e.Message);
end;

end;

我们检查了问题在于步骤#2,因为生成的条形码图像没有任何问题. (我们注释掉了步骤#2并将输出作为BMP文件来确认).

此外,我们尝试了以下解决方法：

>我们使用TExcellentImagePrinter组件来执行调整大小操作.但是,问题没有得到解决.
>我们包含了SETPROCESSWORKINGSETSIZE WinAPI调用以减少/刷新应用程序使用的当前memry.
>我们在代码中包含Sleep(3000),以便Windows能够为映像分配内存.然而,包括睡眠会降低此错误发生的频率.

你能提出任何建议吗？

procedure PrintBarCodeFromBitmap(const aFromBMP: TBitmap;
  const aToCanvas: TCanvas; const aToRect: TRect;
  const aColor: TColor = clBlack);
var I,xStartRect: Integer;
  xFactor: Double;
  xColor: TColor;
  xLastBrush: TBrush;
begin
  xLastBrush := TBrush.Create;
  try
    xLastBrush.Assign(aToCanvas.Brush);

    aToCanvas.Brush.Color := aColor;
    aToCanvas.Brush.Style := bsSolid;

    xFactor := (aToRect.Right-aToRect.Left)/aFromBMP.Width;

    xStartRect := -1;
    for I := 0 to aFromBMP.Width do begin
      if I < aFromBMP.Width then
        xColor := aFromBMP.Canvas.Pixels[I,0]
      else
        xColor := clWhite;

      if (xStartRect < 0) and (xColor = clBlack) then begin
        xStartRect := I;
      end else if (xStartRect >= 0) and (xColor <> clBlack) then begin
        aToCanvas.FillRect(
          Rect(
            Round(aToRect.Left+xStartRect*xFactor),aToRect.Top,Round(aToRect.Left+I*xFactor),aToRect.Bottom));
        xStartRect := -1;
      end;
    end;
  finally
    aToCanvas.Brush.Assign(xLastBrush);

    xLastBrush.Free;
  end;
end;