oopstwain.pas

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

end;

destructor TOopsTwain.Destroy;
begin
  Terminate;
  inherited Destroy;
end;

procedure TOopsTwain.HookWin;
begin
  OldWndProc := TFarProc(GetWindowLong(FHandle, GWL_WNDPROC));
  NewWndProc := MakeObjectInstance(WndProc);
  SetWindowLong(FHandle, GWL_WNDPROC, LongInt(NewWndProc));
  FHooked:=True;
end;

procedure TOopsTwain.UnHookWin;
begin
  If not fHooked then exit;
  SetWindowLong(FHandle, GWL_WNDPROC, LongInt(OldWndProc));
  if AsSigned(NewWndProc) then FreeObjectInstance(NewWndProc);
  NewWndProc := nil;
  FHooked := False;
end;

procedure TOopsTwain.WndProc(var Message: TMessage);
begin
  if not IsDSOpen or not ProcessTWMessage(Message, FHandle) then begin
//    if Message.Msg = PM_XFERDONE then ;
    Message.Result := CallWindowProc(OldWndProc, FHandle, Message.Msg, Message.wParam, Message.lParam);
  end;
end;

function TOopsTwain.ProcessTWMessage(var aMsg: TMessage; TwhWnd: THandle): Boolean;
var
  twRC: TW_UINT16;
  twEv: TW_EVENT;
  theMsg: TMsg;
begin     // Here Something delicacy that MSG of C++ and TMessage of Delphi are not Same.
  twRC := TWRC_NOTDSEVENT;
  if IsDSOpen then begin
    FillChar(twEv, Sizeof(TW_EVENT), #0);
    FillChar(theMsg, Sizeof(TMsg), #0);
    theMsg.hwnd := TwhWnd;
    theMsg.message := aMsg.Msg;
    theMsg.wParam := aMsg.WParam;
    theMsg.lParam := aMsg.LParam;
    twEv.pEvent := @theMsg;
    twRC := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT, @twEv);
    aMsg.Msg := theMsg.message;
    aMsg.WParam := theMsg.wParam;
    aMsg.LParam := theMsg.lParam;
    aMsg.Result := twRC;
    case twEv.TWMessage of
      MSG_XFERREADY : TransferImage;
      MSG_CLOSEDSREQ, MSG_CLOSEDSOK: Terminate;
    end;
  end;
  Result := twRC = TWRC_DSEVENT;
end;

procedure TOopsTwain.TransferImage;
begin
  case FTransferType of
    doNativeTransfer: NativeTransfer;
    doFileTransfer  : FileTransfer;
    doMemTransfer   : MemoryTransfer;
  end;
  //
end;

procedure TOopsTwain.NativeTransfer;
var
  twPendingXfer: TW_PENDINGXFERS;
  twRC, twRC2: TW_UINT16;
  hBitMap: TW_UINT32;
  hbm_acq: THandle;
begin
  hBitMap := 0;
  FillChar(twPendingXfer, sizeof(TW_PENDINGXFERS), #0);
  repeat
    twRC := lpDSM_Entry(@FappID, @FdsID, DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hBitMap);
    case twRC of
      TWRC_XFERDONE:
             begin
               hbm_acq := hBitMap;
               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
                 if (hbm_acq <> 0) and (GlobalLock(hbm_acq) <> nil) then begin
                   Terminate;
                   GlobalUnlock(hbm_acq);
                 end;
               if hbm_acq > VALID_HANDLE
                 then DoXferDone(hbm_acq)
                 else DoXferDone(0);
             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);
               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);
               if twPendingXfer.Count = 0 then Terminate;
               DoXferDone(0);
    end;
  until twPendingXfer.count = 0;
end;

procedure TOopsTwain.FileTransfer;
var
  twPendingXfer: TW_PENDINGXFERS;
  SetupMsgGet, setup: TW_SETUPFILEXFER;
  ofs: OFSTRUCT;
  hF: THandle;
  twRC, twRC2: TW_UINT16;
  hbm_acq: THandle;
  header: BITMAPFILEHEADER;
  dwSize: DWord;
  ptr: PChar;
  count: TW_UINT32;
  num: TW_UINT16;
  FFileName: string;
begin
  FillChar(twPendingXfer, sizeof(TW_PENDINGXFERS), #0);
  FillChar(SetupMsgGet, sizeof(TW_SETUPFILEXFER), #0);
  FillChar(setup, sizeof(TW_SETUPFILEXFER), #0);
  FillChar(ofs, sizeof(OFSTRUCT), #0);
  repeat
    FFileName := '';
    if Assigned(FOnFileNameNeeded) then FOnFileNameNeeded(Self, FFileName);
    if FFileName <> '' then StrPCopy(setup.FileName, FFileName) else begin
      lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_SETUPFILEXFER, MSG_GET, @SetupMsgGet);
      StrCopy(setup.FileName, SetupMsgGet.FileName);
    end;
    setup.Format := TWFF_BMP;
    setup.VRefNum := 0;
    hF := OpenFile(setup.Filename, ofs, OF_CREATE);
    if hF = HFILE_ERROR then begin
      DoTwMessage('Unable to create file for file transfer', False);
      twRC := TWRC_FAILURE;
    end else begin
      _lclose(hF);
      twRC := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_SETUPFILEXFER, MSG_SET, @setup);
      if twRC <> TWRC_SUCCESS
        then DoTwMessage('DG_CONTROL/DAT_SETUPFILEXFER/MSG_SET', False)
        else twRC := lpDSM_Entry(@FappID, @FdsID, DG_IMAGE, DAT_IMAGEFILEXFER, MSG_GET, nil);
      case twRC of
       TWRC_XFERDONE:
         begin
           FillChar(ofs, sizeof(OFSTRUCT), #0);
           FillChar(header, sizeof(BITMAPFILEHEADER), #0);
           hF := OpenFile(setup.FileName, ofs, OF_READ);
           hbm_acq := 0;
           if hF<>Longword(-1) then begin
             num := $8000;
             dwSize := GetFileSize(hF, nil);
             _lread(hF, @header, sizeof(BITMAPFILEHEADER));
             Dec(dwSize, sizeof(BITMAPFILEHEADER));
             if header.bfSize = 0 then header.bfSize := dwSize;
             hbm_acq := GlobalAlloc(GHND, header.bfSize);
             if hbm_acq <> 0 then begin
               ptr := GlobalLock(hbm_acq);
               //for count:=(header.bfSize-sizeof(BITMAPFILEHEADER)) downto count; count-=num, ptr+=num)
               count := header.bfSize - sizeof(BITMAPFILEHEADER);
               while count>0 do begin
                 if count < num then num := count;
                 _lread(hF, ptr, num);
                 Dec(count, num);
                 Inc(ptr, num);
               end;
               GlobalUnlock(hbm_acq);
             end;
             _lclose(hF);
           end;
           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);
           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);
           if twPendingXfer.Count = 0 then Terminate;
           DoXferDone(0);
      end;
    end;
  until ((twPendingXfer.Count = 0) or (twRC = TWRC_FAILURE));
end;

procedure TOopsTwain.MemoryTransfer;
var
  twPendingXfer: TW_PENDINGXFERS;
  info: TW_IMAGEINFO;
  twRC, twRC2  :TW_UINT16;
  size: TW_UINT32;
  setup: TW_SETUPMEMXFER;
  blocks, index: integer;
  hbm_acq: THandle;
  pdib: pBITMAPINFO;
  cap: TW_CAPABILITY;
  pOneV: pTW_ONEVALUE;
  Units, PixelFlavor: TW_UINT16;
  XRes, YRes: Double;
  pal: TW_PALETTE8;
  ptr: PByte;
  xfer: TW_IMAGEMEMXFER;
begin
  FillChar(twPendingXfer, sizeof(TW_PENDINGXFERS), #0);
  FillChar(info, sizeof(TW_IMAGEINFO), #0);
  FillChar(setup, sizeof(TW_SETUPMEMXFER), #0);
  FillChar(pal, sizeof(TW_PALETTE8), #0);
  FillChar(xfer, sizeof(TW_IMAGEMEMXFER), #0);
  repeat
    twRC := lpDSM_Entry(@FappID, @FdsID, DG_IMAGE, DAT_IMAGEINFO, MSG_GET, @info);
    if twRC <> TWRC_SUCCESS then DoTwMessage('DG_IMAGE/DAT_IMAGEINFO/MSG_GET', False) else begin
      size := (((info.ImageWidth * info.BitsPerPixel + 31) div 8) * info.ImageLength);
      lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_SETUPMEMXFER, MSG_GET, @setup);
      blocks := size div setup.Preferred;
      size := (TW_UINT32(blocks) + 1) * setup.Preferred;
      hbm_acq := GlobalAlloc(GHND, size + sizeof(BITMAPINFOHEADER) + 256 * sizeof(RGBQUAD));
      if hbm_acq = 0 then DoTwMessage('GlobalAlloc Failed in DoMemTransfer', False) else begin
        pdib := GlobalLock(hbm_acq);
        // fill in the image information
        pdib^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
        pdib^.bmiHeader.biWidth := info.ImageWidth;
        pdib^.bmiHeader.biHeight := info.ImageLength;
        // Only 1 is supported
        pdib^.bmiHeader.biPlanes := 1;
        pdib^.bmiHeader.biBitCount := info.BitsPerPixel;
        // This application does not support compression
        pdib^.bmiHeader.biCompression := BI_RGB;
        pdib^.bmiHeader.biSizeImage := size;
        // Get Units and calculate PelsPerMeter
        cap.Cap := ICAP_UNITS;
        cap.ConType := TW_UINT16(TWON_DONTCARE16);
        cap.hContainer := 0;
        twRC := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_GETCURRENT, @cap);
        if twRC <> TWRC_SUCCESS then begin
          // raise ETwainError.Create('DG_CONTROL/DAT_CAPABILITY/MSG_GETCURRENT');
          pdib^.bmiHeader.biXPelsPerMeter := 0;
          pdib^.bmiHeader.biYPelsPerMeter := 0;
        end else begin
          pOneV := GlobalLock(cap.hContainer);
          Units := pOneV^.Item;
          GlobalUnlock(cap.hContainer);
          GlobalFree(cap.hContainer);
          XRes := FIX32ToFloat(info.XResolution);
          YRes := FIX32ToFloat(info.YResolution);
          case Units of
           TWUN_INCHES: begin
                          pdib^.bmiHeader.biXPelsPerMeter := Trunc((XRes*2.54)*100);
                          pdib^.bmiHeader.biYPelsPerMeter := Trunc((YRes*2.54)*100);
                        end;
           TWUN_CENTIMETERS:
                        begin
                          pdib^.bmiHeader.biXPelsPerMeter := Trunc(XRes*100);
                          pdib^.bmiHeader.biYPelsPerMeter := Trunc(YRes*100);
                        end;
                   else begin
                          pdib^.bmiHeader.biXPelsPerMeter := 0;
                          pdib^.bmiHeader.biYPelsPerMeter := 0;
                        end;
          end;
          case info.PixelType of
           TWPT_BW:
             begin
               pdib^.bmiHeader.biClrUsed := 2;
               pdib^.bmiHeader.biClrImportant := 0;
               cap.Cap := ICAP_PIXELFLAVOR;
               cap.ConType := TW_UINT16(TWON_DONTCARE16);
               cap.hContainer := 0;
               twRC := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_CAPABILITY, MSG_GETCURRENT, @cap);
               if twRC <> TWRC_SUCCESS then PixelFlavor := TWPF_CHOCOLATE else begin
                 if cap.ConType <> TWON_ONEVALUE then PixelFlavor := TWPF_CHOCOLATE else begin
                   pOneV := GlobalLock(cap.hContainer);
                   PixelFlavor := TW_UINT16(pOneV^.Item);
                   GlobalUnlock(cap.hContainer);
                 end;
                 GlobalFree(cap.hContainer);
               end;
               if PixelFlavor = 0 then begin
                 pdib^.bmiColors[0].rgbRed := 0;
                 pdib^.bmiColors[0].rgbGreen := 0;
                 pdib^.bmiColors[0].rgbBlue := 0;
                 pdib^.bmiColors[0].rgbReserved := 0;
                 index := 1;
                 pdib^.bmiColors[index].rgbRed := $00FF;
                 pdib^.bmiColors[index].rgbGreen := $00FF;
                 pdib^.bmiColors[index].rgbBlue := $00FF;
                 pdib^.bmiColors[index].rgbReserved := 0;
               end else begin
                 pdib^.bmiColors[0].rgbRed := $00FF;
                 pdib^.bmiColors[0].rgbGreen := $00FF;
                 pdib^.bmiColors[0].rgbBlue := $00FF;
                 pdib^.bmiColors[0].rgbReserved := 0;
                 index := 1;
                 pdib^.bmiColors[index].rgbRed := 0;
                 pdib^.bmiColors[index].rgbGreen := 0;
                 pdib^.bmiColors[index].rgbBlue := 0;
                 pdib^.bmiColors[index].rgbReserved := 0;
               end;
             end;
           TWPT_GRAY:
             begin
               pdib^.bmiHeader.biClrUsed := 256;
               for index:=0 to 255 do begin
                 pdib^.bmiColors[index].rgbRed := BYTE(index);
                 pdib^.bmiColors[index].rgbGreen := BYTE(index);
                 pdib^.bmiColors[index].rgbBlue := BYTE(index);
                 pdib^.bmiColors[index].rgbReserved := 0;
               end;
             end;
           TWPT_RGB: pdib^.bmiHeader.biClrUsed := 0;
           else
               twRC := lpDSM_Entry(@FappID, @FdsID, DG_IMAGE, DAT_PALETTE8, MSG_GET, @pal);
               if twRC <> TWRC_SUCCESS then begin
                 // raise ETwainError.Create('DG_IMAGE/DAT_PALETTE8/MSG_GET -- defaulting to 256 gray image palette');
                 pdib^.bmiHeader.biClrImportant := 0;
                 pdib^.bmiHeader.biClrUsed := 256;
                 for index:=0 to pal.NumColors-1 do begin
                   pdib^.bmiColors[index].rgbRed := BYTE(index);
                   pdib^.bmiColors[index].rgbGreen := BYTE(index);
                   pdib^.bmiColors[index].rgbBlue := BYTE(index);
                   pdib^.bmiColors[index].rgbReserved := 0;
                 end;
               end else begin
                 pdib^.bmiHeader.biClrImportant := 0;
                 pdib^.bmiHeader.biClrUsed := pal.NumColors;
                 for index:=0 to pal.NumColors-1 do begin
                   pdib^.bmiColors[index].rgbRed := pal.Colors[index].Channel1;
                   pdib^.bmiColors[index].rgbGreen := pal.Colors[index].Channel2;
                   pdib^.bmiColors[index].rgbBlue := pal.Colors[index].Channel3;
                   pdib^.bmiColors[index].rgbReserved := 0;
                 end;
               end;
          end;
          ptr := PByte(pdib);
          Inc(ptr, sizeof(BITMAPINFOHEADER));
          Inc(ptr, pdib^.bmiHeader.biClrUsed * sizeof(RGBQUAD));
          twRC := lpDSM_Entry(@FappID, @FdsID, DG_CONTROL, DAT_SETUPMEMXFER, MSG_GET, @setup);
          if twRC <> TWRC_SUCCESS then DoTwMessage('DG_CONTROL/DAT_SETUPMEMXFER/MSG_GET', False) else begin
            // we will use a pointer to shared memory
            xfer.Memory.Flags := TWMF_APPOWNS or TWMF_POINTER;
            xfer.Memory.Length := setup.Preferred;