Delphi针对扫描仪编程开发的相关代码
* identify an Application, a Source, or the Source Manager.
* pDest Identifies the destination module for the message.
* This could identify an application or a data source.
* If this is NULL, the message goes to the Source Manager.
* DG The Data Group.
* Example: DG_IMAGE.
* DAT The Data Attribute Type.
* Example: DAT_IMAGEMEMXFER.
* MSG The message. Messages are interpreted by the destination module
* with respect to the Data Group and the Data Attribute Type.
* Example: MSG_GET.
* pData A pointer to the data structure or variable identified
* by the Data Attribute Type.
* Example: (TW_MEMREF)&ImageMemXfer
* where ImageMemXfer is a TW_IMAGEMEMXFER structure.
* Returns:
* ReturnCode
* Example: TWRC_SUCCESS.
********************************************************************}
DSM_Entry = function( pOrigin :pTW_IDENTITY;
pDest :pTW_IDENTITY;
DG :TW_UINT32;
DAT :TW_UINT16;
MSG :TW_UINT16;
pData :TW_MEMREF ) : TW_UINT16; stdcall;
{**********************************************************************
* Function: DS_Entry, the entry point provided by a Data Source.
* Parameters:
* pOrigin Identifies the source module of the message. This could
* identify an application or the Data Source Manager.
* DG The Data Group.
* Example: DG_IMAGE.
* DAT The Data Attribute Type.
* Example: DAT_IMAGEMEMXFER.
* MSG The message. Messages are interpreted by the data source
* with respect to the Data Group and the Data Attribute Type.
* Example: MSG_GET.
* pData A pointer to the data structure or variable identified
* by the Data Attribute Type.
* Example: (TW_MEMREF)&ImageMemXfer
* where ImageMemXfer is a TW_IMAGEMEMXFER structure.
* Returns:
* ReturnCode
* Example: TWRC_SUCCESS.
* Note:
* The DSPROC type is only used by an application when it calls
* a Data Source directly, bypassing the Data Source Manager.
******************************************************************** }
DS_Entry = function ( pOrigin : pTW_IDENTITY;
DG : TW_UINT32;
DAT : TW_UINT16;
MSG : TW_UINT16;
pData : TW_MEMREF) :TW_UINT16; stdcall;
TOnTwRC = procedure(Sender: TObject; const Level: Integer; var ReturnCode: UINT) of object;
TtransferType = (doNativeTransfer,doFileTransfer,doMemTransfer);
TOopsTwain = class(TComponent)
private { Private declarations }
AppID,dsID : TW_IDENTITY;
TWhMainWnd : HWND; // Backup Main Window Handle.
TWDSMOpen, TWDSOpen, TWDSEnabled: Boolean; // Twain Curren States.
FTransferType : TtransferType;
showTwMsg : Boolean;
lpDSM_Entry : DSM_Entry ;
twUI : TW_USERINTERFACE; // Structure of User Interface.
hDSMDLL : THandle; // TWAIN_32.DLL 's Handle.
fHooked : Boolean;
fOnTwEvent : TNotifyEvent;
fOnTwReturnCode :TOnTwRC;
procedure SetTransferType(Value: TtransferType);
procedure SetshowTwMsg(Value: Boolean);
procedure TWshowMessage(Value: String);
procedure TWInitialize; //Must be Loadded after AppMain Form Create;
function TWSelectDS: TW_UINT16;
procedure TWTransferImage;
function ProcessTWMessage(var Message :TMessage; TwhWnd :THandle):Boolean;
procedure NativeTransfer;
procedure FileTransfer;
procedure WndProc(var Message: TMessage);
procedure HookWin;
procedure UnHookWin;
protected { Protected declarations }
OldWndProc : TFarProc;
NewWndProc : Pointer;
Procedure TwXferDone(Var TwEvn : TMessage); Message PM_XFERDONE;
public { Public declarations }
BitMap :TBitMap;
binfo : TW_IMAGEINFO;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function TWOpenDSM: TW_UINT16; // DSM
function TWCloseDSM: TW_UINT16;
function TWisDSMOpen: Boolean;
function TWOpenDS: TW_UINT16; // DS
function TWCloseDS: TW_UINT16;
function TWisDSOpen: Boolean;
function TWEnableDS(Show: Boolean): TW_UINT16; // UI
function TWDisableDS: TW_UINT16;
function TWisDSEnable: Boolean;
procedure TWTerminate;
function SelectSource: TW_UINT16;
function Acquire(Show: Boolean):TW_UINT16;
procedure CurrentDSInfo;
published { Published declarations }
property ShowTwainMessage :Boolean read showTwMsg write SetshowTwMsg;
property TransferType :TtransferType read FTransferType write SetTransferType;
property OnCaptrue :TNotifyEvent read fOnTwEvent write fOnTwEvent;
property OnTwReturnCode :TOnTwRC read fOnTwReturnCode write fOnTwReturnCode;
end;
procedure Register;
implementation
constructor TOopsTwain.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fHooked:=False;
BitMap:=TBitMap.Create;
with AOwner as TForm do TWhMainWnd :=Handle; //Initializing AppID & Backup App's Main Window Handle.
TWInitialize;
end;
destructor TOopsTwain.Destroy;
begin
TWTerminate;
BitMap.DesTroy;
inherited Destroy;
end;
procedure TOopsTwain.HookWin;
begin
OldWndProc := TFarProc(GetWindowLong(TWhMainWnd, GWL_WNDPROC));
NewWndProc := MakeObjectInstance(WndProc);
SetWindowLong(TWhMainWnd, GWL_WNDPROC, LongInt(NewWndProc));
fHooked:=True;
end;
procedure TOopsTwain.UnHookWin;
begin
If not fHooked then exit;
SetWindowLong(TWhMainWnd, GWL_WNDPROC, LongInt(OldWndProc));
if AsSigned(NewWndProc) then FreeObjectInstance(NewWndProc);
NewWndProc := nil;
FHooked := False;
end;
procedure TOopsTwain.SetTransferType(Value: TtransferType);
begin
if FTransferType<>Value then FTransferType:=Value
end;
procedure TOopsTwain.SetshowTwMsg(Value: Boolean);
begin
if showTwMsg<>Value then showTwMsg:=Value
end;
procedure TOopsTwain.TWshowMessage(Value: String);
var TwErrMsg :Array[0..255]of char;
begin
strPcopy(TwErrMsg,Value);
if showTwMsg then MessageBox(TWhMainWnd,TwErrMsg,'TWAIN 出错信息:',MB_ICONWARNING+MB_OK);
end;
procedure TOopsTwain.TWInitialize;
begin
AppID.Id := 0; // init to 0, but Source Manager will assign real value
AppID.Version.MajorNum := 1;
AppID.Version.MinorNum := 0;
AppID.Version.Language := TWLG_ENG;
AppID.Version.Country := TWCY_CHINA;
strcopy (AppID.Version.Info, 'TWAIN_32 Twacker 2.0 01/12/2000');
strcopy (AppID.ProductName, 'OopsWare TWAIN Component');
AppID.ProtocolMajor := TWON_PROTOCOLMAJOR;
AppID.ProtocolMinor := TWON_PROTOCOLMINOR;
AppID.SupportedGroups := DG_IMAGE_OR_CONTROL;
strcopy (AppID.Manufacturer, 'OopsWare Company.');
strcopy (AppID.ProductFamily, 'TWAIN Component for Delphi');
TWDSMOpen := False;
TWDSOpen := False;
TWDSEnabled:= False;
end;
(*************************************************
* Twain function Weither DSM is Openned *
*************************************************)
function TOopsTwain.TWisDSMOpen: Boolean;
begin Result:=TWDSMOpen end;
(*************************************************
* Twain function Weither DS is Openned *
*************************************************)
function TOopsTwain.TWisDSOpen: Boolean;
begin Result:=TWDSOpen end;
(*************************************************
* Twain function Weither DS is Enabled *
*************************************************)
function TOopsTwain.TWisDSEnable: Boolean;
begin Result:=TWDSEnabled end;
(*************************************************
* Twain function: Open DSM *
*************************************************)
function TOopsTwain.TWOpenDSM: TW_UINT16;
var twRC: TW_UINT16;
sWindowsPath: Array [0..200] of char;
begin
Result:= TWRC_FAILURE;
GetWindowsDirectory(sWindowsPath,200);
Strcat(sWindowsPath,'\TWAIN_32.DLL');
hDSMDLL:=LoadLibrary(sWindowsPath);
if (hDSMDLL<>0) and not(TWisDSMOpen) then
begin
@lpDSM_Entry := GetProcAddress(hDSMDLL,'DSM_Entry');
if @lpDSM_Entry <> nil then
begin
twRC:= lpDSM_Entry(@AppID,NIL,DG_CONTROL,DAT_PARENT,MSG_OPENDSM,@TwhMainWnd);
if twRC=TWRC_SUCCESS
then begin TWDSMOpen:=True; Result:=twRC; end
else TWshowMessage('Error Open DSM!'#13#10'DG_CONTROL/DAT_PARENT/MSG_OPENDSM');
end //end if get proc addr has no error!
else TWshowMessage('Error Get DSM Entry!');
end //end if Load TWAIN_32.DLL Error;
else TWshowMessage('Error Load TWAIN_32.DLL');
end;
(*************************************************
* Twain function: Close DSM *
*************************************************)
function TOopsTwain.TWCloseDSM: TW_UINT16;
var twRC: TW_UINT16;
begin
Result:= TWRC_FAILURE;
if TWisDSMOpen then
begin
twRC:= lpDSM_Entry(@AppID,NIL,DG_CONTROL,DAT_PARENT,MSG_CLOSEDSM,@TwhMainWnd);
if twRC<>TWRC_SUCCESS then TWshowMessage('Error Close DSM!'#13#10'DG_CONTROL/DAT_PARENT/MSG_CLOSEDSM');
if hDSMDLL<>0 then FreeLibrary (hDSMDLL); // Free TWAIN_32.DLL
hDSMDLL:= 0;
dsID.Id:= 0;
Result:= twRC;
end
else TWshowMessage('Can not Close DSM while is not Openned');
TWDSMOpen:=False;
end;
(*************************************************
* Twain function: Select DS. *
*************************************************)
function TOopsTwain.TWSelectDS: TW_UINT16;
var twRC: TW_UINT16;
NewDsID: TW_IDENTITY;
begin
Result:=TWRC_FAILURE;
NewDsID.Id:=0;
NewDsID.ProductName[0]:=#0;
if TWisDSMOpen then
if not(TWisDSOpen)then
begin
twRc := lpDSM_Entry(@AppID, NIL, DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT, @NewDsID);
if twRC=TWRC_SUCCESS then dsID := NewDsID;
Result:=twRC;
end
else TWshowMessage('Can not Select New DS while DS is Openning')
else TWshowMessage('Can not Select DS while DSM not Openned');
end;
(*************************************************
* Twain function: Open DS *
*************************************************)
function TOopsTwain.TWOpenDS: TW_UINT16;
var twRC: TW_UINT16;
begin
Result:=TWRC_FAILURE;
if TWisDSMOpen then
if not(TWisDSOpen) then
begin
twRC:= lpDSM_Entry(@AppID, NIL, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, @dsID);
if twRC=TWRC_SUCCESS then
begin
TWDSOpen:=True;
HookWin;
end
else TWshowMessage('Error Open DS'#13#10'DG_CONTROL/DAT_IDENTITY/MSG_OPENDS');
Result:=twRC;
end
else TWshowMessage('Can not Open DS while It is Openning')
else TWshowMessage('Can not Open DS while DSM not Openning');
end;
(*************************************************
* Twain function: Close DS *
*************************************************)
function TOopsTwain.TWCloseDS: TW_UINT16;
var twRC: TW_UINT16;
begin
Result:=TWRC_FAILURE;
if TWisDSOpen then
if not(TWisDSEnable) then
begin
twRC:= lpDSM_Entry(@AppID, NIL, DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS, @dsID);
if twRC=TWRC_SUCCESS then
begin
TWDSOpen:=False;
UnHookWin;
end
else TWshowMessage('Error Close DS'#13#10'DG_CONTROL/DAT_IDENTITY/MSG_CLOSEDS');
dsID.Id := 0;
dsID.ProductName[0] := #0;
Result:=twRC;
end
else TWshowMessage('Can not Close DS while DS is Enabled')
else TWshowMessage('Can not Close DS while it is not Openning');
TWDSOpen:=False;
end;
(*************************************************
* Twain function: Enable DS *
*************************************************)
function TOopsTwain.TWEnableDS(Show: Boolean): TW_UINT16;
var twRC: TW_UINT16;
begin
Result:=TWRC_FAILURE;
if TWisDSOpen then
if not(TWisDSEnable) then
begin
twUI.hParent := TWhMainWnd;
if Show then twUI.ShowUI := 1
else twUI.ShowUI := 0;
twRC:= lpDSM_Entry(@AppID, @dsID, DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS, @twUI);
if twRC=TWRC_SUCCESS
then TWDSEnabled:=True
else TWshowMessage('Error Enable DS'#13#10'DG_CONTROL/DAT_USERINTERFACE/MSG_ENABLEDS');
Result:=twRC;
end
else TWshowMessage('Can not Enable DS while it already Enabled')
else TWshowMessage('Can not Enable DS while DS is not Openning');
end;
(*************************************************
* Twain function: Disable DS *
*************************************************)
function TOopsTwain.TWDisableDS: TW_UINT16;
var twRC: TW_UINT16;
begin
Result:=TWRC_FAILURE;
if TWisDSEnable then
begin
twUI.hParent := TWhMainWnd;
twUI.ShowUI := TWON_DONTCARE8;
twRC:= lpDSM_Entry(@AppID, @dsID, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, @twUI);
if twRC=TWRC_SUCCESS
then TWDSEnabled:=False
else TWshowMessage('Error Disable DS'#13#10'DG_CONTROL/DAT_USERINTERFACE/MSG_DISABLEDS');
Result:=twRC;
end
else TWshowMessage('Can not Disable DS while DS Already Disabled');
TWDSEnabled:=False;
end;
(**************************************************
* Twain Terminate *
**************************************************)
procedure TOopsTwain.TWTerminate;
begin
TWDisableDS;
TWCloseDS;
TWCloseDSM;
end;
(**************************************************
* Twain Select Source *
* Return Code *
* 0 :Success, 1 :failure, 3 :User do cancel *
**************************************************)
function TOopsTwain.SelectSource: TW_UINT16;
begin
Result:=TWRC_FAILURE;
if not(TWisDSMOpen) then TWOpenDSM;
if TWisDSOpen then Exit; //Can't Do Select While DS is Openning!
Result:=TWSelectDS;
if TWisDSMOpen then TWCloseDSM;
end;
function TOopsTwain.Acquire(Show: Boolean):TW_UINT16;
var twRC :TW_UINT16;
begin
twRC:=TWRC_FAILURE;
Result:=TWRC_FAILURE;
if not(TWisDSMOpen) then twRC:=TWOpenDSM;
if twRC<>TWRC_SUCCESS then Exit;
if not(TWisDSOpen) then twRC:=TWOpenDS;
if twRC<>TWRC_SUCCESS then Exit;
if not(TWisDSEnable) then Result:=TWEnableDS(True);
end;
procedure TOopsTwain.CurrentDSInfo;
var TwDsInfo: Array [0..400] of Char;
DispDsInfo :TW_IDENTITY;
begin
if not(TWisDSMOpen) then
begin
if TWOpenDSM<>TWRC_SUCCESS then Exit;
if TWOpenDS<>TWRC_SUCCESS then Exit;
DispDsInfo:=dsID; TWCloseDS ; TWCloseDSM;
TwDsInfo[0]:=#0;
StrCat(TwDsInfo,'设备版本: '); StrCat(TwDsInfo,DispDsInfo.Version.Info); StrCat(TwDsInfo,#13#10);
StrCat(TwDsInfo,'设备名称: '); StrCat(TwDsInfo,DispDsInfo.ProductName); StrCat(TwDsInfo,#13#10);
StrCat(TwDsInfo,'设备型号: '); StrCat(TwDsInfo,DispDsInfo.ProductFamily); StrCat(TwDsInfo,#13#10);
StrCat(TwDsInfo,'制 造 商: '); StrCat(TwDsInfo,DispDsInfo.Manufacturer); StrCat(TwDsInfo,#13#10);
StrCat(TwDsInfo,'----------------------------------------'#13#10#13#10);
StrCat(TwDsInfo,'TWAIN Component 1.1 for Delphi'#13#10#13#10);
StrCat(TwDsInfo,'Copyright (C) 1995-2000 OopsWare Company.'#13#10);
StrCat(TwDsInfo,'E-Mail: qiangdu@hotmail.com');
MessageBox(TWhMainWnd,TwDsInfo,'当前的扫描仪设备驱动信息.',MB_ICONINFORMATION+MB_OK);
end
end;
function TOopsTwain.ProcessTWMessage(var Message :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;
Result:=False;
if TWIsDSOpen then
begin
theMsg.hWnd:=TWhMainWnd;
theMsg.message:=Message.Msg;
theMsg.wParam:=Message.WParam;
theMsg.lParam:=Message.LParam;
twEv.pEvent := @theMsg; //twEvent.pEvent = (TW_MEMREF)lpMsg;
twRC :=lpDSM_Entry(@appID, @dsID, DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT, @twEv);
case twEv.TWMessage of
MSG_XFERREADY :TWTransferImage;
MSG_CLOSEDSREQ :TWTerminate;
end;
Message.Msg :=theMsg.message;
Message.WParam :=theMsg.wParam;
Message.LParam :=theMsg.lParam;
end;
if twRC=TWRC_DSEVENT
then Result:=True;
end;
procedure TOopsTwain.TWTransferImage;
begin
case FTransferType of
doNativeTransfer : NativeTransfer;
doFileTransfer : FileTransfer;
doMemTransfer : ;
end;
end;
procedure TOopsTwain.NativeTransfer;
var twPendingXfer: TW_PENDINGXFERS;
lpDib, lpBi :PBITMAPINFOHEADER;
lpBits :Pointer;
dwColorTableSize: TW_UINT32;
LogPal : TMaxLogPalette; // Color Palette.
twRC, twRC2 :TW_UINT16;
hBitMap :TW_UINT32;
hbm_acq, hDibPal :THandle;
mDC :HDC;
begin
dwColorTableSize := 0;
twPendingXfer.count:= 0;
repeat
twRC := lpDSM_Entry(@appID,@dsID,DG_IMAGE,DAT_IMAGENATIVEXFER,MSG_GET,@hBitMap);
case twRC of
TWRC_XFERDONE:begin
hbm_acq := hBitMap;
twRC2 :=lpDSM_Entry(@appID,@dsID,DG_CONTROL,DAT_PENDINGXFERS,MSG_ENDXFER,@twPendingXfer);
if twRC2<>TWRC_SUCCESS then TWshowMessage('DG_CONTROL/DAT_PENDINGXFERS/MSG_ENDXFER');
if twPendingXfer.Count = 0 then
begin
lpdib := GlobalLock(hbm_acq);
if (lpdib<>NIL) then
begin
TWTerminate;
lpBi := lpDib;
case lpBi^.biBitCount of
1 : dwColorTableSize := 8;
4 : dwColorTableSize := 64;
8 : dwColorTableSize := 1024;
24 : dwColorTableSize := 0;
end;
lpBits := Pointer(Longint(lpDib) + Longint(lpBi^.biSize) + Longint(dwColorTableSize));
mDC := GetDC(TWhMainWnd);
LogPal.palVersion :=$0300; LogPal.palNumEntries :=256;
hDibPal:=CreatePalette(PLogPalette(@LogPal)^);
if hDibPal<>0 then
begin
SelectPalette (mDC, hDibPal, FALSE);
RealizePalette (mDC);
end;
Bitmap.Handle := CreateDIBitmap (mDC, (lpDib)^, CBM_INIT, lpBits,PBitMapInfo(lpDib)^ , DIB_RGB_COLORS);
ReleaseDC (TWhMainWnd, mDC);
GlobalUnlock(hbm_acq);
OnCaptrue(Self);
end
else TWshowMessage('Could Not Lock Bitmap Memory');
end;
end;
TWRC_CANCEL :begin
TWshowMessage('Source (or User) Canceled Transfer');
end;
TWRC_FAILURE :begin
TWshowMessage('TWRC_FAILURE');
end;
else begin
TWshowMessage('Other Error Code');
end;
end; //End Case .
until twPendingXfer.count=0;
end;
procedure TOopsTwain.FileTransfer;
var twImageInfo :TW_IMAGEINFO;
twRC : TW_UINT16;
s,ss : array[0..400]of char;
st,stt : string;
begin
lpDSM_Entry(@appID,@dsID,DG_IMAGE,DAT_IMAGEINFO,MSG_GET,@twImageInfo);
lpDSM_Entry(@appID,@dsID,DG_IMAGE,DAT_IMAGEINFO,MSG_GET,@ss[0]);
stt:='';
for twRC:=0 to 40 do
stt:=stt+inttostr(ord(ss[twRC]))+',';
TWTerminate;
st:='XRes:'+inttostr(twImageInfo.XResolution.Whole)+' YRes:'+inttostr(twImageInfo.YResolution.Whole)+#13#10;
st:=st+'Width:'+inttostr(twImageInfo.ImageWidth)+' Height:'+inttostr(twImageInfo.ImageLength)+#13#10;
st:=st+'SPP:'+inttostr(twImageInfo.SamplesPerPixel)+' BPP:'+inttostr(twImageInfo.BitsPerPixel)+#13#10;
st:=st+stt;
StrPCopy(s,st);
MessageBox(TWhMainWnd,s,'info',MB_OK);
end;
Procedure TOopsTwain.TwXferDone(Var TwEvn : TMessage);
begin
OnCaptrue(Self);
end;
procedure TOopsTwain.WndProc(var Message: TMessage);
begin
if not(ProcessTWMessage(Message,TWhMainWnd)) then
Message.Result := CallWindowProc(OldWndProc, TWhMainWnd, Message.Msg, Message.wParam, Message.lParam);
end;
procedure Register;
begin
RegisterComponents('OopsWare', [TOopsTwain]);
end;
end.