scanners.pas

控制扫描仪的源码,可以方便的控制扫描仪及照像机

procedure TWCloseDSM;
begin
  if TWDSOpen then
    raise ETwainError.Create(SErrDSOpen);

  if TWDSMOpen then
  begin
    // This call performs one important function:
    // - tells the SM which application, appID.id, is requesting SM to close
    // - be sure to test return code, failure indicates SM did not close !!

    TwainCheckDSM(CallDSMEntry(nil, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM,
      @hMainWnd), 'TWCloseDSM');

    TWDSMOpen := False;

    UnloadTwain;
  end;
end;

function TWIsDSMOpen: Boolean;
begin
  Result := TWDSMOpen;
end;

procedure TWOpenDS;
begin
  Assert(TWDSMOpen, 'DSM must be open');

  if not TWDSOpen then
  begin
    TwainCheckDSM(CallDSMEntry(nil, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, @dsID),
      'TWOpenDS');
    TWDSOpen := True;
  end;
end;

procedure TWCloseDS;
begin
  Assert(TWDSMOpen, 'DSM must be open');
  if TWDSOpen then
  begin
    TwainCheckDSM(CallDSMEntry(nil, DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS, @dsID),
      'TWCloseDS');
    TWDSOpen := False;
  end;
end;

procedure TWEnableDS(show: Boolean);
var
  twUI: TW_USERINTERFACE;
begin
  Assert(TWDSOpen, 'DS must be open');

  if not TWDSEnabled then
  begin
    FillChar(twUI, SizeOf(twUI), #0);

    twUI.hParent := hMainWnd;
    twUI.ShowUI := show;

    TwainCheckDSM(CallDSMEntry(@dsID, DG_CONTROL, DAT_USERINTERFACE,
      MSG_ENABLEDS, @twUI), 'TWEnableDS');

    TWDSEnabled := True;
  end;
end;

procedure TWEnableDSUIOnly;
var
  twUI: TW_USERINTERFACE;
begin
  Assert(TWDSOpen, 'DS must be open');

  if not TWDSEnabled then
  begin
    FillChar(twUI, SizeOf(twUI), #0);

    twUI.hParent := hMainWnd;
    twUI.ShowUI := True;

    TwainCheckDSM(CallDSMEntry(@dsID, DG_CONTROL, DAT_USERINTERFACE,
      MSG_ENABLEDSUIONLY, @twUI), 'TWEnableDSUIOnly');

    TWDSEnabled := True;
  end;
end;

procedure TWDisableDS;
var
  twUI: TW_USERINTERFACE;
begin
  Assert(TWDSOpen, 'DS must be open');

  if TWDSEnabled then
  begin
    twUI.hParent := hMainWnd;
    twUI.ShowUI := TW_BOOL(TWON_DONTCARE8); (*!!!!*)

    TwainCheckDSM(CallDSMEntry(@dsID, DG_CONTROL, DAT_USERINTERFACE,
      MSG_DISABLEDS, @twUI), 'TWDisableDS');

    TWDSEnabled := False;
  end;
end;

function TWIsDSOpen: Boolean;
begin
  Result := TWDSOpen;
end;

function TWIsDSEnabled: Boolean;
begin
  Result := TWDSEnabled;
end;

procedure TWSelectDS;
var
  NewDSIdentity: TW_IDENTITY;
  twRC: TW_UINT16;
begin
  Assert(not TWDSOpen, 'Source must not be open');

  TwainCheckDSM(CallDSMEntry(nil, DG_CONTROL, DAT_IDENTITY, MSG_GETDEFAULT,
    @NewDSIdentity), 'TWSelectDS:Select Default');

  twRC := CallDSMEntry(nil, DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT,
    @NewDSIdentity);

  case twRC of
    TWRC_SUCCESS:
      dsID := NewDSIdentity; // log in new Source
    TWRC_CANCEL:
      ;                      // keep the current Source
  else
    TwainCheckDSM(twRC, 'TWSelectDS:User Select');
  end;
end;

(*******************************************************************
  Functions from CAPTEST.C
*******************************************************************)
procedure TWXferMech(transfer: TTWTransfer);
var
  cap: TW_CAPABILITY;
  pVal: pTW_ONEVALUE;
begin
  cap.Cap := ICAP_XFERMECH;
  cap.ConType := TWON_ONEVALUE;

  cap.hContainer := GlobalAlloc(GHND, SizeOf(TW_ONEVALUE));
  Assert(cap.hContainer <> 0);
  try

    pval := pTW_ONEVALUE(GlobalLock(cap.hContainer));
    Assert(pval <> nil);
    try
      pval.ItemType := TWTY_UINT16;
      case transfer of
        ttMemory:
          pval.Item := TWSX_MEMORY;
        ttFile:
          pval.Item := TWSX_FILE;
      else
        pval.Item := TWSX_NATIVE
      end;
    finally
      GlobalUnlock(cap.hContainer);
    end;

    TwainCheckDS(DSCall(DG_CONTROL, DAT_CAPABILITY, MSG_SET, @cap),
      'Set Xfer Mech');

  finally
    GlobalFree(cap.hContainer);
  end;

end;


(*******************************************************************
  Functions from DCA_ACQ.C
*******************************************************************)
function ProcessSourceMessage(var Msg: TMsg): Boolean;
var
  twRC: TW_UINT16;
  event: TW_EVENT;
  pending: TW_PENDINGXFERS;
begin
  Result := False;

  if TWDSMOpen and TWDSOpen then
  begin
    event.pEvent := @Msg;
    event.TWMessage := 0;

    twRC := DSCall(DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT, @event);

    case event.TWMessage of
      MSG_XFERREADY:
      begin
        // ToDo!
        TWNativeTransfer;

        TwainCheckDS(DSCall(DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @pending),
          'Check for Pending Transfers');

        if pending.Count > 0 then
          TwainCheckDS(DSCall(DG_CONTROL, DAT_PENDINGXFERS, MSG_RESET,
            @pending), 'Abort Pending Transfers');

        TWDisableDS;
        TWCloseDS;
      end;
      MSG_CLOSEDSOK, MSG_CLOSEDSREQ:
      begin
        TWDisableDS;
        TWCloseDS;
      end;
    end;

    Result := not (twRC = TWRC_NOTDSEVENT);
  end;
end;

procedure TWAcquire(hWnd: HWND; aBmp: TBitmap; show: Boolean);
begin
  bmp := aBmp;

  TWOpenDSM(hWnd);
  TWOpenDS;
  TWXferMech(ttNative);
  TWEnableDS(True);

  // Here could be my own message loop with processSourceMessage
  // inside? (similar to TCustomForm.ShowModal)

  // Or the alternative:
  // An 'invisible' Form (Size=0) shown per ShowModal ?!
end;

function TWNativeTransfer: Boolean;

  function DibNumColors(dib: Pointer): Integer;
  var
    lpbi: PBITMAPINFOHEADER;
    lpbc: PBITMAPCOREHEADER;
    bits: Integer;
  begin
    lpbi := dib;
    lpbc := dib;

    if lpbi.biSize <> SizeOf(BITMAPCOREHEADER) then
    begin
      if lpbi.biClrUsed <> 0 then
      begin
        Result := lpbi.biClrUsed;
        Exit;
      end;
      bits := lpbi.biBitCount;
    end
    else
      bits := lpbc.bcBitCount;

    case bits of
      1:
        Result := 2;
      4:
        Result := 4;
      8:
        Result := 8;
    else
      Result := 0;
    end;
  end;

var
  twRC: TW_UINT16;
  hDIB: TW_UINT32;
  hBmp: HBITMAP;
  lpDib: ^TBITMAPINFO;
  lpBits: PChar;
  ColorTableSize: Integer;
  dc: HDC;

begin
  Result := False;

  twRC := DSCall(DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hDIB);

  case twRC of
    TWRC_XFERDONE:
      begin
        lpDib := GlobalLock(hDIB);
        try
          ColorTableSize := (DibNumColors(lpDib) * SizeOf(RGBQUAD));

          lpBits := PChar(lpDib);
          Inc(lpBits, lpDib.bmiHeader.biSize);
          Inc(lpBits, ColorTableSize);

          dc := GetDC(0);
          try
            hBMP := CreateDIBitmap(dc, lpdib.bmiHeader, CBM_INIT,
              lpBits, lpDib^, DIB_RGB_COLORS);

            bmp.Handle := hBMP;

            Result := True;
          finally
            ReleaseDC(0, dc);
          end;
        finally
          GlobalUnlock(hDIB);
          GlobalFree(hDIB);
        end;
      end;

    TWRC_CANCEL:
      ;

    TWRC_FAILURE:
      RaiseLastDSMCondition('Native Transfer');
  end;
end;

end.