请访问:www.horseb.org
www.horseb.net
作者主页
unit BaseScan;interfaceusesWindows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, TWainH, extctrls, Clipbrd, Buttons, FileCtrl, ShellAPI;const WM_SCANBASE = WM_USER + $101;typeTClearBlankFunc = function(hBmp: THandle; topBeg,topEnd,bottomBeg,bottomEnd: Integer;r: Single): Integer; stdcall;TSaveDIBFunc = function(HWND, BmpHandel: THandle; FileName: PChar): Integer; stdcall;TWInitialize = procedure(pIdentity: pTW_IDENTITY; hMainWnd: HWND;nXFerType: TW_INT16; strFileName: Pchar; wMsgBase: WPARAM); stdcall;//1:use memory tranfer//2:file transfer//3:native transferSetMessageLevel = procedure(Level: integer); stdcall;TWOpenDSM = function: Bool; stdcall;TWIsDSMOpen = function: Bool; stdcall;TWIsDSOpen = function: Bool; stdcall;TWSelectDS = function: Bool; stdcall;CloseConnection = procedure(Bitmap: THANDLE); stdcall; //***ProcessTWMessage = function(pMsg: PMsg; m_hWnd: Thandle): Bool; stdcall;TWAcquire = function(hWnd: THandle; ShowUI: BOOL; Flag: TW_INT16): Bool; stdcall;ResetID = procedure; stdcall;TWCloseDSM = function(Bitmap: THANDLE): Bool; stdcall; //***TBaseScanForm = class(TForm)ScanBtn: TButton;SelectDvcBtn: TButton;NewScanBtn: TButton;AddScanBtn: TButton;CheckBlank: TCheckBox;Label1: TLabel;BitBtn1: TBitBtn;BitBtn2: TBitBtn;Edit1: TEdit;Edit2: TEdit;Edit3: TEdit;Edit4: TEdit;Edit5: TEdit;procedure FormCreate(Sender: TObject);procedure FormClose(Sender: TObject; var Action: TCloseAction);procedure ScanBtnClick(Sender: TObject);procedure SelectDvcBtnClick(Sender: TObject);procedure FormDestroy(Sender: TObject);procedure FormShow(Sender: TObject);procedure AddScanBtnClick(Sender: TObject);procedure NewScanBtnClick(Sender: TObject);private{ Private declarations }TifCount: Integer;AppIdentity: TW_IDENTITY;ConvertHandle: THandle;Dllhandle, ClearBlankHandle: Thandle;PTWAcquire, PTWIsDSMOpen, PTWIsDSOpen, PProcessTWMessage:TFarProc;//TFarProc=pointer-----WindowsPTWOpenDSM, PTWSelectDS, PTWCloseDSM, PResetID:TFarProc;PTSaveDIBFunc, PClearBlank: TFarProc;function InitScanner: Boolean;procedure WMScanbase(var Msg: TMessage); Message WM_SCANBASE;procedure WMScanbase1(var Msg: TMessage); Message WM_SCANBASE+1;function DeleteFileInPath: Boolean;function GetMaxFileName: Integer;publicInde: Integer;Savepath: String;Perfix: String;procedure AppMessage(var Msg: TMsg; var Handled: Boolean);end;const ML_NONE = 0;const ML_ERROR = 1;const ML_INFO = 2;const ML_FULL = 3;const VALID_HANDLE = 32; // valid windows handle SB >= 32varBaseScanForm: TBaseScanForm;implementation{$R *.DFM}function TBaseScanForm.InitScanner: Boolean;varPTWInitialize:TFarProc;//TFarProc=pointer-----WindowsPSetMessageLevel:TFarProc;//TFarProc=pointer-----WindowsbeginResult := False;AppIdentity.Id := 0; // init to 0, but Source Manager will assign real valueAppIdentity.Version.MajorNum := 1;AppIdentity.Version.MinorNum := 5;AppIdentity.Version.Language := TWLG_USA;AppIdentity.Version.Country := TWCY_CHINA;lstrcpy(AppIdentity.Version.Info, '1TIDE1.0 9/1/98');lstrcpy(AppIdentity.ProductName, 'TIDE1.0');AppIdentity.ProtocolMajor := TWON_PROTOCOLMAJOR;AppIdentity.ProtocolMinor := TWON_PROTOCOLMINOR;AppIdentity.SupportedGroups := DG_IMAGE or DG_CONTROL;lstrcpy(AppIdentity.Manufacturer, 'Chinese HanWang Company');lstrcpy(AppIdentity.ProductFamily, 'TIDE');// pass app particulars to glue codePTWInitialize:=GetProcAddress(DllHandle, Pchar('_TWInitialize@20'));PSetMessageLevel:=GetProcAddress(DllHandle,Pchar('_SetMessageLevel@4'));if (PTWInitialize<>Nil) and (PSetMessageLevel<>Nil) thenbegintryTWInitialize(PTWInitialize)(@AppIdentity, Self.Handle, 3, '', WM_SCANBASE);SetMessageLevel(PSetMessageLevel)(ML_ERROR); //show error message onlyResult := True;exceptend;end;end;procedure TBaseScanForm.FormCreate(Sender: TObject);beginClearBlankHandle := LoadLibrary(Pchar('ClearBlank.dll'));if ClearBlankHandle<=0 thenbeginShowMessage('不能启动ClearBlank.DLL');exit;end;PClearBlank := GetProcAddress(ClearBlankHandle,Pchar('ClearBlank'));if PClearBlank=Nil thenbeginShowMessage('调用函数失败。');exit;end;ConvertHandle := LoadLibrary(Pchar('Convert.dll'));if ConvertHandle<=0 thenbeginShowMessage('不能启动Convert.DLL');exit;end;Dllhandle := LoadLibrary(Pchar('scdll32.dll'));if DllHandle<=0 thenbeginShowMessage('不能启动scdll32.DLL');exit;end;PTSaveDIBFunc := GetProcAddress(ConvertHandle,Pchar('HDIB2Tiff'));if PTSaveDIBFunc=Nil thenbeginShowMessage('调用函数失败。');exit;end;PResetID := GetProcAddress(DllHandle,Pchar('_ResetID@0'));PTWOpenDSM := GetProcAddress(DllHandle,Pchar('_TWOpenDSM@0'));PTWSelectDS := GetProcAddress(DllHandle,Pchar('_TWSelectDS@0'));PTWCloseDSM := GetProcAddress(DllHandle,Pchar('_TWCloseDSM@4'));PTWAcquire:=GetProcAddress(DllHandle,Pchar('_TWAcquire@12'));PTWIsDSOpen:=GetProcAddress(DllHandle,Pchar('_TWIsDSOpen@0'));PTWIsDSMOpen:=GetProcAddress(DllHandle,Pchar('_TWIsDSMOpen@0'));PProcessTWMessage:=GetProcAddress(DllHandle,Pchar('_ProcessTWMessage@8'));if (PTWIsDSOpen=Nil) or (PTWIsDSMOpen=Nil) or (PProcessTWMessage=Nil) thenbeginShowMessage('调用函数失败。');exit;end;end;procedure TBaseScanForm.FormClose(Sender: TObject; var Action: TCloseAction);varPCloseConnection: TFarProc;beginPCloseConnection:=GetProcAddress(DllHandle,Pchar('_CloseConnection@4'));if PTWIsDSOpen<>Nil thenCloseConnection(PCloseConnection)(0);end;procedure TBaseScanForm.AppMessage(var Msg: TMsg; var Handled: Boolean);begintryHandled := TWIsDSOpen(PTWIsDSOpen) and TWIsDSMOpen(PTWIsDSMOpen) and ProcessTWMessage(PProcessTWMessage)(@Msg, Self.Handle); //show error message onlyexceptHandled := False;Exit;end{ for all other messages, Handled remains False }{ so that other message handlers can respond }end;procedure TBaseScanForm.WMScanbase(var Msg: TMessage);varm: String;beginif Msg.WParam = 0 thenMsg.Result := 11elsebeginif CheckBlank.Checked thenif TClearBlankFunc(PClearBlank)(Msg.WParam, StrToInt(Edit2.Text), StrToInt(Edit3.Text), StrToInt(Edit4.Text), StrToInt(Edit5.Text), StrToFloat(Edit1.Text)) <> 0 thenExit;Inde := Inde + 1;if Inde<10 thenm := '000'+IntToStr(Inde)else if (Inde >=10) and (Inde<100) thenm := '00'+IntToStr(Inde)else if (Inde >=100) and (Inde<1000) thenm := '0'+IntToStr(Inde)else if Inde >=1000 thenm := IntToStr(Inde);if TSaveDIBFunc(PTSaveDIBFunc)(0, Msg.WParam,PChar(SavePath+'/'+Perfix+m+'.tif'))<>0 thenSHowMessage('调用Conver失败')elseTifCount := TifCount + 1;end;end;procedure TBaseScanForm.WMScanbase1(var Msg: TMessage);beginScanBtn.Enabled := not Bool(Msg.WParam);Sleep(1000);NewScanBtn.Enabled := ScanBtn.Enabled;AddScanBtn.Enabled := ScanBtn.Enabled;Label1.Caption := '本次扫描共扫了'+IntToStr(TifCount)+'幅图象。';Msg.Result := 11;end;procedure TBaseScanForm.ScanBtnClick(Sender: TObject);beginInde := GetMaxFileName;TifCount := 0;if TWIsDSOpen(PTWIsDSOpen) thenResetID(PResetID);if not TWAcquire(PTWAcquire)(Self.Handle, True, 1) thenShowMessage('请检查扫描仪是否能正常工作。');end;procedure TBaseScanForm.SelectDvcBtnClick(Sender: TObject);beginif TWOpenDSM(PTWOpenDSM) thenbeginTWSelectDS(PTWSelectDS);TWCloseDSM(PTWCloseDSM)(0);end;end;procedure TBaseScanForm.FormDestroy(Sender: TObject);beginif DLLHandle > 0 thenFreelibrary(DllHandle);if ConvertHandle > 0 thenFreelibrary(ConvertHandle);if ClearBlankHandle > 0 thenFreelibrary(ClearBlankHandle);end;procedure TBaseScanForm.FormShow(Sender: TObject);beginSavepath := 'D:/testTif';Perfix := 'p';if not InitScanner thenbeginShowMessage('扫描初始化失败。');Close;end;end;procedure TBaseScanForm.AddScanBtnClick(Sender: TObject);beginInde := GetMaxFileName;TifCount := 0;if TWIsDSOpen(PTWIsDSOpen) thenResetID(PResetID);if not TWAcquire(PTWAcquire)(Self.Handle, True, 1) thenShowMessage('请检查扫描仪是否能正常工作。');end;procedure TBaseScanForm.NewScanBtnClick(Sender: TObject);beginif MessageBox(Application.Handle, Pchar('执行该操作会先把原来的图象删除，再重新扫描，你确定吗？'),Pchar('确认操作'), MB_ICONWARNING or MB_OKCANCEL) <> IDOK then Exit;DeleteFileInPath;Inde := GetMaxFileName;TifCount := 0;if TWIsDSOpen(PTWIsDSOpen) thenResetID(PResetID);if not TWAcquire(PTWAcquire)(Self.Handle, True, 1) thenShowMessage('请检查扫描仪是否能正常工作。');end;function TBaseScanForm.DeleteFileInPath: Boolean;varF:TShFileOpStruct;beginF.wnd:=0;F.wFunc:=FO_DELETE; {操作方式}F.pFrom:=PChar(SavePath + '/*.*' +#0#0);F.pTo:=PChar(''+#0#0);F.fFlags:=FOF_SILENT or FOF_NOCONFIRMATION;result:= ShFileOperation(F)=0;end;function TBaseScanForm.GetMaxFileName: Integer;function GetCount(Str: String): Integer;begintryResult := StrToInt(Copy(Str,2,4));exceptResult := 0;end;end;varSR: TSearchRec;Temp: Integer;beginResult := 0;if DirectoryExists(SavePath) thenbeginif FindFirst(SavePath + '/'+Perfix+'*.tif', faAnyFile, SR) = 0 thenbeginTemp := GetCount(SR.Name);if Temp > Result thenResult := Temp;while FindNext(sr) = 0 dobeginTemp := GetCount(SR.Name);if Temp > Result thenResult := Temp;end;FindClose(sr);end;endelseif not CreateDir(SavePath) thenbeginShowMessage('不能创建目录'+SavePath+'，程序将关闭。');Close;end;end;end.
