Processing Barcode image with Delphi 6 using StretchDIBits - Missing Bar lines in the output

问题

My application is developed in Delphi 6. This is a resource intesive application due to background processing and large volume of data (It consumes around 60MB - 120MB of physical memory). One of the functionality of this application is to create barcode images after doing certain procesing. If user keeps on generating the Barcodes, then at least One out of Ten Barcode has missing lines in it. We have following steps in generating the output:

Create a Barcode image (TImage) in the memory. The height of the image is 10 pixels. We use pf24bit pixel format.
Resizing the image in the memory according to printer's canvas and passing it to the printer's canvas. The code for Step # 2 is as following :

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,
                0, 0, biWidth, biHeight, Image, Info^, 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,'RptWrks2','PrintBitmap','Exception in PrintBitMap with message '+e.Message);
end;

end;

We checked that the issue lies in the Step # 2 , as the barcode image is generated without any issue. (We commented out Step # 2 and took the output as BMP files to confirm this).

Also, we tried following workarounds :

We used TExcellentImagePrinter component to perform the resizing operation. But, issue was not resolved.
We included SETPROCESSWORKINGSETSIZE WinAPI call to reduce/refresh the current memry used by the application.
We included Sleep(3000) in the code so that the Windows is able to allocate the memory for the image. Including Sleep however reduced the frequency of occurrence of this error.

Can you please provide any suggestions?

回答1:

I use this function for printing barcodes with great success. It assumes that the bitmap is 100% scaled barcode (each x-pixel is a barcode stripe), the height does not matter, it may be only 1px.

The clue is to print the barcode with fillrect and not as a bitmap: The function just "reads" the barcode and draws it with fillrect to some canvas. If the resulting scale (xFactor = aToRect width to barcode width) is either an integer number or a big enough real number (for printers no problem) the printed barcode can be read without any problems. It also works great with PDF Printers.

You just have to generate a 100% scaled barcode to bitmap (as you already do; height may be 1px; color of the barcode must be clBlack) and pass it in the aFromBMP parameter. aToCanvas will then be your printer canvas. aToRect is the destination rect in printer canvas. aColor is the color of the destination barcode (may be everything).

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;