oopstwain.pas

控制扫描仪的组件 控制扫描仪的组件

            xfer.Memory.TheMem := ptr;
            // transfer the data -- loop until done or canceled
            repeat
              twRC := lpDSM_Entry(@FappID, @FdsID, DG_IMAGE, DAT_IMAGEMEMXFER, MSG_GET, @xfer);
              case twRC of
               TWRC_SUCCESS:
                 begin
                   Inc(ptr, xfer.BytesWritten);
                   xfer.Memory.TheMem := ptr;
                 end;
               TWRC_XFERDONE:
                 begin
                   GlobalUnlock(hbm_acq);
                   FlipBitMap(FHandle, hbm_acq, info.PixelType);
                   twRC2 := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @twPendingXfer);
                   if twRC2 <> TWRC_SUCCESS then DoTwMessage('DG_CONTROL / DAT_PENDINGXFERS / MSG_ENDXFER', False);
                   if twPendingXfer.Count = 0 then Terminate;
                   DoXferDone(hbm_acq);
                 end;
               TWRC_CANCEL:
                 begin
                   // DoTwMessage('User Cancel. (DG_IMAGE/DAT_IMAGENATIVEXFER/MSG_GET)', False);
                   twRC2 := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @twPendingXfer);
                   if twRC2 <> TWRC_SUCCESS then DoTwMessage('DG_CONTROL / DAT_PENDINGXFERS / MSG_ENDXFER', False);
                   GlobalUnlock(hbm_acq);
                   GlobalFree(hbm_acq);
                   if twPendingXfer.Count = 0 then Terminate;
                   DoXferDone(0);
                 end;
               else
                   twRC2 := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @twPendingXfer);
                   if twRC2 <> TWRC_SUCCESS then DoTwMessage('DG_CONTROL / DAT_PENDINGXFERS / MSG_ENDXFER', False);
                   GlobalUnlock(hbm_acq);
                   GlobalFree(hbm_acq);
                   if twPendingXfer.Count = 0 then Terminate;
                   DoXferDone(0);
              end;
            until (twRC <> TWRC_SUCCESS);
          end; // if twRC <> TWRC_SUCCESS then DoTwMessage('DG_CONTROL/DAT_SETUPMEMXFER/MSG_GET', False) else begin
        end;
      end;  // hbm_acq = 0
    end; // twRC <> TWRC_SUCCESS
  until twPendingXfer.count = 0;
end;

procedure TOopsTwain.DoXferDone(hDib: THandle);
var
  lpDib, lpBi: PBITMAPINFOHEADER;
  lpBits: Pointer;
  dwColorTableSize: TW_UINT32;
  hBitMap: TW_UINT32;
  hDibPal: THandle;
  DC: HDC;
  bmp: TBitmap;
begin
  if not Assigned(FOnCapture) then Exit;
  if hDib = 0 then begin
    FOnCapture(Self, nil);
    Exit;
  end;
  lpDib := GlobalLock(hDib);
  if lpDib = nil then begin
    DoTwMessage('Could Not Lock Bitmap Memory.', False);
    Exit;
  end;
  lpBi := lpDib;
  dwColorTableSize := DibNumColors(lpDib) * sizeof(RGBQUAD);
  lpBits := lpDib;
  Inc(pByte(lpBits), lpBi^.biSize + dwColorTableSize);
  DC := GetDC(FHandle);
  hDibPal := CreateBIPalette(lpBi);
  if hDibPal <> 0 then begin
    SelectPalette(DC, hDibPal, False);
    RealizePalette(DC);
  end;
  if lpDib^.biBitCount = 1 then begin
    hBitMap := CreateBitmap(lpDib^.biWidth, lpDib^.biHeight, 1, 1, lpBits);
    if hBitMap <> 0 then SetDIBits(DC, hBitMap, 0, lpDib^.biHeight, lpBits, pBITMAPINFO(lpDib)^, DIB_RGB_COLORS);
  end else hBitMap := CreateDIBitmap(DC, lpDib^, CBM_INIT, lpBits, pBITMAPINFO(lpDib)^, DIB_RGB_COLORS);
  GlobalUnlock(hDib);
  ReleaseDC(FHandle, DC);
  bmp := TBitmap.Create;
  bmp.Handle := hBitMap;
  FOnCapture(Self, bmp);
  bmp.Free;
end;

procedure TOopsTwain.DoTwMessage(Msg: string; TerminateDS: Boolean = True);
begin
  if TerminateDS then Terminate;
  if Assigned(FOnTwMessage) then FOnTwMessage(Self, Msg);
end;

function TOopsTwain.OpenDSM: TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if IsDSMOpen then Exit;
  hDSMDLL := LoadLibrary('TWAIN_32.DLL');
  if hDSMDLL <> 0 then @lpDSM_Entry := GetProcAddress(hDSMDLL, 'DSM_Entry');
  if (hDSMDLL = 0) or (@lpDSM_Entry = nil)
    then DoTwMessage('Error in Open, LoadLibrary, or GetProcAddress.');
  Result := lpDSM_Entry(@FAppID, nil, DG_CONTROL, DAT_PARENT, MSG_OPENDSM, @FHandle);
  if Result = TWRC_SUCCESS
    then FIsDSMOpen := True
    else DoTwMessage('Error Open DSM. (DG_CONTROL/DAT_PARENT/MSG_OPENDSM)');
end;

function TOopsTwain.CloseDSM: TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if IsDSMOpen then begin
    Result := lpDSM_Entry(@FAppID, nil, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, @FHandle);
    if hDSMDLL <> 0 then begin
      FreeLibrary(hDSMDLL);
      hDSMDLL := 0;
    end;
    if Result <> TWRC_SUCCESS then DoTwMessage('Error Close DSM. (DG_CONTROL/DAT_PARENT/MSG_CLOSEDSM)');
    FdsID.Id:= 0;
  end;
  FIsDSMOpen := False;
end;

function TOopsTwain.OpenDS: TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if IsDSMOpen then
    if not IsDSOpen then begin
      Result := lpDSM_Entry(@FAppID, nil, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, @FdsID);
      if Result = TWRC_SUCCESS then begin
        FIsDSOpen := True;
        HookWin;
      end else DoTwMessage('Error Open DS. (DG_CONTROL/DAT_IDENTITY/MSG_OPENDS)');
    end else DoTwMessage('Can not Open DS while It is Openning')
  else DoTwMessage('Can not Open DS while DSM not Openning');
end;

function TOopsTwain.CloseDS: TW_UINT16;
begin
  Result:=TWRC_FAILURE;
  if IsDSOpen then
    if not IsDSEnabled then begin
      Result := lpDSM_Entry(@FAppID, nil, DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS, @FdsID);
      if Result = TWRC_SUCCESS then begin
        FIsDSOpen := False;
        UnHookWin;
      end else DoTwMessage('Error Close DS. (DG_CONTROL/DAT_IDENTITY/MSG_CLOSEDS)');
      FillChar(FdsID, Sizeof(TW_IDENTITY), #0);
    end else DoTwMessage('Can not Close DS while DS is Enabled');
  FIsDSOpen:=False;
end;

function TOopsTwain.XferMechDS: TW_UINT16;
var
  cap: TW_CAPABILITY;
  pval: pTW_ONEVALUE;
begin
  Result := TWRC_FAILURE;
  cap.Cap := ICAP_XFERMECH;
  cap.ConType := TWON_ONEVALUE;
  cap.hContainer := GlobalAlloc(GHND, Sizeof(TW_ONEVALUE));
  if cap.hContainer = 0 then begin
    DoTwMessage('Memory Allocation Failed. (MSG_SET/ICAP_XFERMECH)');
    Exit;
  end;
  pval := GlobalLock(cap.hContainer);
  pval^.ItemType := TWTY_UINT16;
  case FTransferType of
    doNativeTransfer: pval^.Item := TWSX_NATIVE;
    doFileTransfer  : pval^.Item := TWSX_FILE;
    doMemTransfer   : pval^.Item := TWSX_MEMORY;
  end;
  GlobalUnlock(cap.hContainer);
  Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @cap);
  GlobalFree(cap.hContainer);
  if Result <> TWRC_SUCCESS then DoTwMessage('Error XferMech DS. (DG_CONTROL/DAT_CAPABILITY/MSG_SET)');
end;

function TOopsTwain.AutoFeedDS: TW_UINT16;
var
  cap: TW_CAPABILITY;
  pval: pTW_ONEVALUE;
begin
  Result := TWRC_SUCCESS;
  if not FAutoFeed then Exit;
  // Get Feeder Enabled
  FillChar(cap, Sizeof(TW_CAPABILITY), 0);
  cap.Cap := CAP_FEEDERENABLED;
  cap.ConType := TWON_ONEVALUE;
  Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, @cap);
  if Result <> TWRC_SUCCESS then begin
    GlobalFree(cap.hContainer);
    DoTwMessage('Error get AutoFeed. (DG_CONTROL/DAT_CAPABILITY/MSG_GET)');
    Exit;
  end;
  pval := GlobalLock(cap.hContainer);
  if pval^.Item <> 0 then begin  // Feeder Enabled
    GlobalUnlock(cap.hContainer);
    GlobalFree(cap.hContainer);
  end else begin
    // Set Feeder Enabled
    pval^.ItemType := TWTY_BOOL;
    pval^.Item := 1;  // TRUE
    Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @cap);
    GlobalFree(cap.hContainer);
    if Result = TWRC_SUCCESS then begin
      // Verify Feeder Enabled
      Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, @cap);
      if Result = TWRC_SUCCESS then begin
        pval := GlobalLock(cap.hContainer);
        if pval^.Item = 0 then Result := TWRC_FAILURE; // not set
        GlobalUnlock(cap.hContainer);
        GlobalFree(cap.hContainer);
      end else DoTwMessage('Error Get AutoFeed. (DG_CONTROL, DAT_CAPABILITY, MSG_GET)');
    end else DoTwMessage('Error Get AutoFeed. (DG_CONTROL, DAT_CAPABILITY, MSG_SET)');
  end;

  if Result = TWRC_SUCCESS then begin
    // Get AutoFeed
    cap.Cap := CAP_AUTOFEED;
    cap.ConType := TWON_ONEVALUE;
    Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, @cap);
    pval := GlobalLock(cap.hContainer);
    if pval^.Item <> 0 then begin  // already auto feed
      GlobalUnlock(cap.hContainer);
      GlobalFree(cap.hContainer);
    end else begin
      // Set AutoFeed
      pval^.ItemType := TWTY_BOOL;
      pval^.Item := 1; // TRUE;
      GlobalUnlock(cap.hContainer);
      Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @cap);
      GlobalFree(cap.hContainer);
      if Result = TWRC_SUCCESS then begin
        // Verify AutoFeed
        Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, @cap);
        if Result = TWRC_SUCCESS then begin
          pval := GlobalLock(cap.hContainer);
          if pval^.Item <> 0 then Result := TWRC_FAILURE;  // not been set
          GlobalUnlock(cap.hContainer);
          GlobalFree(cap.hContainer);
        end;
      end else DoTwMessage('Error set AutoFeed. (DG_CONTROL, DAT_CAPABILITY, MSG_SET)');
    end;
  end;
//  AutoFeedBOOL := Result = TWRC_SUCCESS;
end;

function TOopsTwain.EnableDS(Show: Boolean): TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if IsDSOpen then
    if not IsDSEnabled then begin
      twUI.hParent := FHandle;
      twUI.ModalUI := 0; // Mac Only..
      if Show then twUI.ShowUI := 1 else twUI.ShowUI := 0;
      Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS, @twUI);
      if Result = TWRC_SUCCESS
        then FIsDSEnabled := True
        else DoTwMessage('Error Enable DS. (DG_CONTROL/DAT_USERINTERFACE/MSG_ENABLEDS)');
    end else DoTwMessage('Can not Enable DS while it already Enabled')
  else DoTwMessage('Can not Enable DS while DS is not Openning');
end;

function TOopsTwain.DisableDS: TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if IsDSEnabled then begin
    twUI.hParent := FHandle;
    twUI.ShowUI  := TW_BOOL(TWON_DONTCARE8);
    Result := lpDSM_Entry(@FAppID, @FdsID, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, @twUI);
    if Result = TWRC_SUCCESS
      then FIsDSEnabled :=False
      else DoTwMessage('Error Disable DS. (DG_CONTROL/DAT_USERINTERFACE/MSG_DISABLEDS)');
  end;
  FIsDSEnabled:=False;
end;

function TOopsTwain.SelectDS: TW_UINT16;
var
  NewDsID: TW_IDENTITY;
begin
  Result := TWRC_FAILURE;
  NewDsID.Id:=0;
  NewDsID.ProductName[0]:=#0;
  if not IsDSOpen then begin
    Result := lpDSM_Entry(@FAppID, nil, DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT, @NewDsID);
    if Result = TWRC_SUCCESS then  FdsID := NewDsID;
  end else DoTwMessage('Can not Select New DS while DS is Openning');
end;

function TOopsTwain.Acquire(Show: Boolean):TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if not IsDSMOpen then Result := OpenDSM;
  if Result <> TWRC_SUCCESS then Exit;
  if not IsDSOpen then Result := OpenDS;
  if Result <> TWRC_SUCCESS then Exit;
  Result := XferMechDS;
  if Result <> TWRC_SUCCESS then Exit;
  Result := AutoFeedDS;
  if Result <> TWRC_SUCCESS then Exit;
  if not IsDSEnabled then Result := EnableDS(Show);
end;

function TOopsTwain.GetDSInfo(var DsID: TW_IDENTITY): TW_UINT16;
begin
  Result := TWRC_FAILURE;
  if not FIsDSMOpen then begin
    if OpenDSM <> TWRC_SUCCESS then Exit;
    if OpenDS <> TWRC_SUCCESS then Exit;
    DsID := FDsID;
    Result := TWRC_SUCCESS;
    CloseDS;
    CloseDSM;
  end else // DSM Openned.
    if FIsDSOpen then begin
      DsID := FDsID;
      Result := TWRC_SUCCESS;
    end else begin
      if OpenDS <> TWRC_SUCCESS then Exit;
      DsID := FDsID;
      CloseDS;
    end;
end;

function TOopsTwain.GetComponentInfo(var DsID: TW_IDENTITY): TW_UINT16;
begin
  Result := TWRC_SUCCESS;
  DsID := FAppId;
end;

function TOopsTwain.SelectSource: TW_UINT16;
begin
  Result:=TWRC_FAILURE;
  if not IsDSMOpen then OpenDSM;
  if IsDSOpen then begin //Can't Do Select While DS is Openning!
    DoTwMessage('Can''t Do Select While DS is Openning.', False);
    Exit;
  end;
  Result := SelectDS;
  if IsDSMOpen then CloseDSM;
end;

procedure TOopsTwain.Terminate;
begin
  DisableDS;
  CloseDS;
  CloseDSM;
end;

procedure Register;
begin
  RegisterComponents('OopsWare', [TOopsTwain]);
end;

end.