imscan.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

      nState := 5;
    end;
    IETW_EmptyMessageQueue(grec);
    result := (nState <= 5);
    if result then
      LogWrite('  IETW_AbortAllPendingXfers : Ok')
    else
      LogWrite('  IETW_AbortAllPendingXfers : FAILED!')
  end;
end;

///////////////////////////////////////////////////////////////////////////////////////
// supported 1bit(black/write), 8bit(grayscale), 24bit(truecolor)

procedure CopyBuffer(var grec: tgrec; Bitmap: TIEBitmap; const twImageInfo: TW_IMAGEINFO; const imxfer: TW_IMAGEMEMXFER; LockMemory: boolean);
var
  src, dst: pbyte; // source buffer
  sinc: integer; // source row length DWORDed
  pb: pbyte; // dest buffer
  row, col: integer;
  t1: integer;
  px: PRGB;
  pw,pxw:pword;
begin
{$WARNINGS OFF}
  LogWrite('CopyBuffer compression=' + inttostr(imxfer.Compression) + ' BytesPerRow=' + inttostr(imxfer.BytesPerRow) + ' Columns=' + inttostr(imxfer.Columns) + ' Rows=' +
    inttostr(imxfer.Rows) + ' XOffset=' + inttostr(imxfer.XOffset) + ' YOffset=' + inttostr(imxfer.YOffset) + ' BytesWritten=' + inttostr(imxfer.BytesWritten));
  if LockMemory then
    src := GlobalLock(integer(imxfer.Memory.TheMem)) // source data
  else
    src := imxfer.Memory.TheMem;
  sinc := imxfer.BytesPerRow;
  case twImageInfo.BitsPerPixel of
    48:
      // RGB 48 bit (16 bit per channel)
      if grec.NativePixelFormat then
        // native pixel format
        for row := 0 to imxfer.Rows - 1 do
        begin
          t1 := row + imxfer.YOffset;
          if t1 >= Bitmap.Height then
            break;
          dst := Bitmap.Scanline[t1];
          inc(dst, imxfer.XOffset * 6); // select column
          CopyMemory(dst,src,imxfer.Columns*6);
          inc(src, sinc);
        end
      else
        // convert to 24 bit
        for row := 0 to imxfer.Rows - 1 do
        begin
          t1 := row + imxfer.YOffset;
          if t1 >= Bitmap.Height then
            break;
          dst := Bitmap.Scanline[t1];
          inc(dst, imxfer.XOffset * 3); // select column
          px:=PRGB(dst);
          pw:=pword(src);
          for col := 0 to imxfer.Columns - 1 do
          begin
            px^.r:=pw^ shr 8; inc(pw);
            px^.g:=pw^ shr 8; inc(pw);
            px^.b:=pw^ shr 8; inc(pw);
            inc(px);
          end;
          inc(src, sinc);
        end;
    24:
      // truecolor (24bit)
      for row := 0 to imxfer.Rows - 1 do
      begin
        t1 := row + imxfer.YOffset;
        if t1 >= Bitmap.Height then
          break;
        dst := Bitmap.Scanline[t1];
        inc(dst, imxfer.XOffset * 3); // select column
        _CopyBGR_RGB(PRGB(dst), PRGB(src), imxfer.Columns);
        inc(src, sinc);
      end;
    16:
      // 16 bit gray scale
      if grec.NativePixelFormat then
      begin
        // native pixel format
        for row := 0 to imxfer.Rows - 1 do
        begin
          t1 := row + imxfer.YOffset;
          if t1 >= Bitmap.Height then
            break;
          pxw := Bitmap.Scanline[t1];
          inc(pxw, imxfer.XOffset); // select column
          pw := pword(src);
          for col := 0 to imxfer.Columns - 1 do
          begin
            pxw^ := pw^;
            inc(pxw);
            inc(pw);
          end;
          inc(src, sinc);
        end;
      end
      else
        // convert to 24 bit
        for row := 0 to imxfer.Rows - 1 do
        begin
          t1 := row + imxfer.YOffset;
          if t1 >= Bitmap.Height then
            break;
          dst := Bitmap.Scanline[t1];
          inc(dst, imxfer.XOffset * 3); // select column
          pw := pword(src);
          px := PRGB(dst);
          for col := 0 to imxfer.Columns - 1 do
          begin
            with px^ do
            begin
              r := pw^ shr 8;
              g := r;
              b := r;
            end;
            inc(pw);
            inc(px);
          end;
          inc(src, sinc);
        end;
    8:
      // grayscale (8bit)
      if grec.NativePixelFormat then
      begin
        // native pixel format
        for row := 0 to imxfer.Rows - 1 do
        begin
          t1 := row + imxfer.YOffset;
          if t1 >= Bitmap.Height then
            break;
          dst := Bitmap.Scanline[t1];
          inc(dst, imxfer.XOffset); // select column
          pb := src;
          for col := 0 to imxfer.Columns - 1 do
          begin
            dst^ := pb^;
            inc(pb);
            inc(dst);
          end;
          inc(src, sinc);
        end;
      end
      else
        // convert to 24 bit
        for row := 0 to imxfer.Rows - 1 do
        begin
          t1 := row + imxfer.YOffset;
          if t1 >= Bitmap.Height then
            break;
          dst := Bitmap.Scanline[t1];
          inc(dst, imxfer.XOffset * 3); // select column
          pb := src;
          px := PRGB(dst);
          for col := 0 to imxfer.Columns - 1 do
          begin
            with px^ do
            begin
              r := pb^;
              g := pb^;
              b := pb^;
            end;
            inc(pb);
            inc(px);
          end;
          inc(src, sinc);
        end;
    1:
      begin
        // black/write (1bit)
        for row := 0 to imxfer.Rows - 1 do
        begin
          dst := Bitmap.Scanline[row + imxfer.YOffset];
          _CopyBits(dst, src, imxfer.XOffset, 0, imxfer.Columns, 2147483647);
          inc(src, sinc);
        end;
      end;
  end;
  if LockMemory then
    GlobalUnlock(integer(imxfer.Memory.TheMem));
  LogWrite('CopyBuffer : Ok');
{$WARNINGS ON}
end;

function GetOneBool(var grec: tgrec; var Value: boolean; cap: TW_UINT16): boolean;
var
  twCapability: TW_CAPABILITY;
  pvalOneValue: pTW_ONEVALUE;
  pbol: pTW_BOOL;
begin
  result := true;
  if not GetCapability(grec, twCapability, cap) then
  begin
    result := false;
    exit;
  end;
  if twCapability.ConType = TWON_ONEVALUE then
  begin
    pvalOneValue := GlobalLock(twCapability.hContainer);
    pbol := @(pvalOneValue^.Item);
    Value := pbol^;
    GlobalUnlock(twCapability.hContainer);
  end
  else
    result := false;
  GlobalFree(twCapability.hContainer);
end;

function GetOneUINT16(var grec: tgrec; var Value: integer; cap: TW_UINT16): boolean;
var
  twCapability: TW_CAPABILITY;
  pvalOneValue: pTW_ONEVALUE;
  puint16: pTW_UINT16;
begin
  result := true;
  if not GetCapability(grec, twCapability, cap) then
  begin
    result := false;
    exit;
  end;
  if twCapability.ConType = TWON_ONEVALUE then
  begin
    pvalOneValue := GlobalLock(twCapability.hContainer);
    puint16 := @(pvalOneValue^.Item);
    Value := puint16^;
    GlobalUnlock(twCapability.hContainer);
  end
  else
    result := false;
  GlobalFree(twCapability.hContainer);
end;


///////////////////////////////////////////////////////////////////////////////////////
// Supported TW_ONEVALUE (current value)

function SetOneBoolCapability(var grec: tgrec; value: boolean; cap: TW_UINT16): boolean;
var
  twCapability: TW_CAPABILITY;
  pvalOneValue: pTW_ONEVALUE;
begin
  if not GetCapability(grec, twCapability, cap) then
  begin
    result := false;
    exit;
  end;
  GlobalFree(twCapability.hContainer);
  twCapability.Cap := cap;
  // write TW_ONEVALUE (current value only)
  LogWrite('SetOnBoolCapability');
  twCapability.ConType := TWON_ONEVALUE;
  twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
  pvalOneValue := GlobalLock(twCapability.hContainer);
  pvalOneValue^.ItemType := TWTY_BOOL;
  pvalOneValue^.Item := ord(value);
  GlobalUnLock(twCapability.hContainer);
  IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
  result := grec.rc = TWRC_SUCCESS;
  GlobalFree(twCapability.hContainer);
  if result then
    LogWrite('  SetOnBoolCapability : Ok')
  else
    LogWrite('  SetOnBoolCapability : FAILED!');
end;

procedure settemppath(os:pchar);
var
  s:string;
begin
  s:=IEGetTempFileName2+'.bmp';
  if length(s)>254 then
    s:=DefTEMPPATH+'imageentwain03.bmp';
  if length(s)>254 then
    s:='imageentwain03.bmp';
  StrCopy(os,pchar(s));
end;

procedure IETW_XferReady(var grec: tgrec; pmsg: PMSG);
var
  hNative: TW_UINT32;
  setupmemxfer: TW_SETUPMEMXFER;
  setupfilexfer: TW_SETUPFILEXFER;
  imxfer: TW_IMAGEMEMXFER;
  hbuff: THandle;
  twImageInfo: TW_IMAGEINFO;
  pimxfer: pTW_IMAGEMEMXFER;
  DelayImageInfo: boolean; // if true recall ImageInfo after loaded all buffers
  buffers: TList;
  ptr: pointer;
  i: integer;
  pixfor: TIEPixelFormat;
  io: TImageEnIO;
  //
  function ImageInfo: boolean;
  begin
    LogWrite('IETW_XferReady.ImageInfo');
    DelayImageInfo := false;
    result := true;
    try
      with grec do
      begin
        if not IETW_DS(grec, DG_IMAGE, DAT_IMAGEINFO, MSG_GET, TW_MEMREF(@twImageInfo)) then
        begin
          IETW_AbortAllPendingXfers(grec);
          result := false;
          LogWrite('IETW_XferReady.ImageInfo : not available!');
          exit;
        end;
        if (TransferMode <> tmFile) and ((twImageInfo.PixelType > 2) or (twImageInfo.Planar <> false) or (twImageInfo.Compression <> 0)) then
          TransferMode := tmNative;
        case twImageInfo.BitsPerPixel of
          1..8:
            begin
              IOParams.BitsPerSample := twImageInfo.BitsPerPixel;
              IOParams.SamplesPerPixel := 1;
            end;
          24:
            begin
              IOParams.BitsPerSample := 8;
              IOParams.SamplesPerPixel := 3;
            end;
          48:
            begin
              IOParams.BitsPerSample := 8;
              IOParams.SamplesPerPixel := 4;
            end;
        end;
        IOParams.DpiX := round(twImageInfo.XResolution.Whole + twImageInfo.XResolution.Frac / 65536);
        IOParams.DpiY := round(twImageInfo.YResolution.Whole + twImageInfo.YResolution.Frac / 65536);
        IOParams.Width := twImageInfo.ImageWidth;
        IOParams.Height := twImageInfo.ImageLength;
        if IOParams.ColorMap <> nil then
        begin
          freemem(IOParams.ColorMap);
          IOParams.fColorMap := nil;
          IOParams.fColorMapCount := 0;
        end;
        if (IOParams.Width < 0) or (IOParams.Height < 0) then
        begin
          DelayImageInfo := true;
          result := true;
          exit;
        end;
        if (IOParams.Width = 0) or (IOParams.Height = 0) then
        begin
          IETW_AbortAllPendingXfers(grec);
          result := false;
          exit;
        end;
        if NativePixelFormat then
        begin
          case twImageInfo.BitsPerPixel of
            1: pixfor:=ie1g;
            8: pixfor:=ie8g;
            16: pixfor:=ie16g;
            24: pixfor:=ie24RGB;
            48: pixfor:=ie48RGB;
          end;
        end
        else
        begin
          if (IOParams.BitsPerSample = 1) and (IOParams.SamplesPerPixel = 1) then
            pixfor := ie1g
          else
            pixfor := ie24RGB;
        end;
        if (fBitmap.Width <> IOParams.Width) or (fBitmap.Height <> IOParams.Height) or (fBitmap.PixelFormat <> pixfor) then
          fBitmap.allocate(IOParams.Width, IOParams.Height, pixfor);
      end;
    except
      LogWrite('  IETW_XferReady.ImageInfo : exception!');
      if result then
      begin
        IETW_AbortAllPendingXfers(grec);
        result := false;
      end;
    end;
    LogWrite('  IETW_XferReady.ImageInfo : end');
  end;
  //
begin
{$WARNINGS OFF}
  LogWrite('IETW_XferReady');
  with grec do
  begin
    if not ImageInfo then
    begin
      fAborting := true;
      LogWrite('IETW_XferReady : ABORTED, image info not available!');
      exit;
    end;
    //DelayImageInfo:=true;	// uncomment to force undefined size (test only)
    case TransferMode of
      tmBuffered: