BSOne.SFC/EM.Lib/ImageEn_SRC/Source/imscan.pas

3719 lines
115 KiB
Plaintext

(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
(*
Copyright (c) 1998-2017 by Carlotta Calandra. All rights reserved.
Copyright (c) 2011-2017 by Xequte Software.
This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.
Author grants you the right to include the component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE.
ImageEn, IEvolution and ImageEn ActiveX may not be included in any
commercial, shareware or freeware libraries or components.
www.ImageEn.com
*)
(*
File version 1011
*)
unit imscan;
{$R-}
{$Q-}
{$I ie.inc}
{$IFDEF IEINCLUDEIEXACQUIRE}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, ImageEnIO, ietwain, hyiedefs, iexBitmaps, dialogs;
type
TIETWCloseCallBack = procedure of object;
function IETW_SelectImageSource(var SelectedSourceName: AnsiString; TwainShared: PIETwainShared; callwnd: HWND): boolean;
function IETW_Acquire(Bitmap: TIEBitmap; multi: boolean; MultiCallBack: TIEMultiCallBack; Params: TIETwainParams; IOParams: TIOParams; var Progress: TProgressRec; TwainShared: PIETwainShared; callwnd: HWND; DoNativePixelFormat: boolean): boolean;
function IETW_GetSourceList(SList: TList; TwainShared: PIETwainShared; callwnd: HWND): boolean;
function IETW_GetCapabilities(Params: TIETwainParams; var Capabilities: TIETWSourceCaps; setcap: boolean; TwainShared: PIETwainShared; callwnd: HWND): boolean;
function IETW_GetDefaultSource(TwainShared: PIETwainShared; callwnd: HWND): AnsiString;
procedure IETW_FreeResources(TwainShared: PIETwainShared; callwnd: HWND);
function IETW_IsCapabilitySupported(Params: TIETwainParams; TwainShared: PIETwainShared; callwnd: HWND; cap: word): boolean;
// new implementation
function IETWAINAcquireOpen(CloseCallBack: TIETWCloseCallBack; MultiCallBack: TIEMultiCallBack; Params: TIETwainParams; TwainShared: PIETwainShared; IOParams: TIOParams; parent: TWinControl; DoNativePixelFormat: boolean): pointer;
procedure IETWAINAcquireClose(var grec: pointer);
implementation
uses
ImageEnProc, forms, iesettings, hyieutils;
{$R-}
type
ErrorDetail = (
ED_NONE,
ED_START_TRIPLET_ERRS,
ED_CAP_GET, // MSG_GET triplet on a capability failed
ED_CAP_SET, // MSG_SET triplet on capability failed
ED_DSM_FAILURE, // TWAIN DSM returned TWRC_FAILURE
ED_DS_FAILURE, // source returned TWRC_FAILURE
ED_END_TRIPLET_ERRS,
ED_NOT_STATE_4, // operation invoked in wrong state
ED_NULL_HCON, // MSG_GET returned a null container handle
ED_BAD_HCON, // MSG_GET returned an invalid/unlockable container handle
ED_BAD_CONTYPE, // returned container ConType is not valid.
ED_BAD_ITEMTYPE, // returned container ItemType is not valid.
ED_CAP_GET_EMPTY, // returned container has 0 items.
ED_CAP_SET_EMPTY // trying to restrict a cap to empty set
);
TIEDPI = record
xdpi: integer;
ydpi: integer;
end;
PIEDPI = ^TIEDPI;
const
{$ifdef WIN64}
DSM_FILENAME: AnsiString = 'System32\TWAINDSM.dll';
{$else}
DSM_FILENAME: AnsiString = 'TWAIN_32.DLL';
{$endif}
DSM_ENTRYPOINT: AnsiString = 'DSM_Entry';
TWAIN_PRESESSION = 1; // source manager not loaded
TWAIN_SM_LOADED = 2; // source manager loaded
TWAIN_SM_OPEN = 3; // source manager open
TWAIN_SOURCE_OPEN = 4; // source open but not enabled
TWAIN_SOURCE_ENABLED = 5; // source enabled to acquire
TWAIN_TRANSFER_READY = 6; // image ready to transfer
TWAIN_TRANSFERRING = 7; // image in transit
TWAIN_BW = $0001; // 1-bit per pixel, B&W (== TWPT_BW)
TWAIN_GRAY = $0002; // 1, 4, or 8-bit grayscale (== TWPT_GRAY)
TWAIN_RGB = $0004; // 24-bit RGB color (== TWPT_RGB)
TWAIN_PALETTE = $0008; // 1, 4, or 8-bit palette (== TWPT_PALETTE)
TWAIN_ANYTYPE = $0000; // any of the above
type
pgrec = ^tgrec;
TIEProxyWin = class
public
grec: pgrec;
handle: HWND;
constructor Create(xgrec: pgrec);
destructor Destroy; override;
procedure WndProc(var Message: TMessage);
end;
tgrec = record
nState: integer; // TWAIN state (per the standard)
hDSMLib: THANDLE; // handle of DSM
DSM_Entry: TDSMEntryProc; // entry point of Data Source Manager (TWAIN.DLL)
hwndSM: HWND;
rc: TW_INT16; // result code
AppId: TW_IDENTITY;
SourceId: TW_IDENTITY; // source identity structure
twUI: TW_USERINTERFACE;
nErrDetail: ErrorDetail; // detailed error code
nErrRC, nErrCC: word; // result code and condition code for last error
pendingXfers: TW_PENDINGXFERS;
gmulti: boolean;
MultiCallBack: TIEMultiCallBack;
fAborting: boolean;
TWParams: TIETwainParams;
IOParams: TIOParams;
NativePixelFormat: boolean; // copy of IOParams.IsNativePixelFormat or TImageEnMIO.NativePixelFormat, you should read this value instead of IOParams.IsNativePixelFormat
TransferMode: (tmNative, tmBuffered, tmFile);
transferdone: boolean; // true on transfer completed
closedsok: boolean; // true when MSG_CLOSEDSOK has been received
breakmodalloop: boolean;
fBitmap: TIEBitmap; // bitmap to fill
Progress: PProgressRec;
PTwainShared: PIETwainShared;
actwnd: HWND;
callwnd: HWND;
proxywnd: HWND;
BWToInvert: boolean; // the black/white image need to be inverted
uionly: boolean; // IETW_EnableSource will use MSG_ENABLEDSUIONLY instead of MSG_ENABLEDS
// new implementation
ProxyWin: TIEProxyWin;
modal: boolean;
sending: boolean;
fclosecallback: TIETWCloseCallBack;
fWindowList: pointer;
end;
function GetUINT16asInteger(var grec: tgrec; ilist: TIEIntegerList; cap: TW_UINT16): boolean; forward;
procedure IETW_EmptyMessageQueue(var grec: tgrec); forward;
procedure LogWrite(ss: AnsiString);
begin
if iegTwainLogName <> '' then
begin
closefile(iegTwainLogFile);
assignfile(iegTwainLogFile, string(iegTwainLogName));
append(iegTwainLogFile);
WriteLn(iegTwainLogFile, AnsiString(datetostr(date)) + ' ' + AnsiString(timetostr(time)) + ' : ' + ss);
Flush(iegTwainLogFile);
end;
end;
function ResultToStr(rsl: TW_UINT16): AnsiString;
begin
case rsl of
TWCC_BADCAP: Result := 'Capability not supported by Source or operation (get, set) is not supported on capability, or capability had dependencies on other capabilities and cannot be operated upon at this time';
TWCC_BADDEST: Result := 'Unknown destination in DSM_Entry.';
TWCC_BADPROTOCOL: Result := 'Unrecognized operation triplet.';
TWCC_BADVALUE: Result := 'Data parameter out of supported range.';
TWCC_BUMMER: Result := 'General failure. Unload Source immediately.';
TWCC_CAPUNSUPPORTED: Result := 'Capability not supported by Source.';
TWCC_CAPBADOPERATION: Result := 'Operation not supported on capability.';
TWCC_CAPSEQERROR: Result := 'Capability has dependencies on other capabilities and cannot be operated upon at this time.';
TWCC_DENIED: Result := 'File System operation is denied (file is protected).';
TWCC_PAPERDOUBLEFEED: Result := 'Transfer failed because of a feeder error';
TWCC_FILEEXISTS: Result := 'Operation failed because file already exists.';
TWCC_FILENOTFOUND: Result := 'File not found.';
TWCC_LOWMEMORY: Result := 'Not enough memory to complete operation.';
TWCC_MAXCONNECTIONS: Result := 'Source is connected to maximum supported number of applications.';
TWCC_NODS: Result := 'Source Manager unable to find the specified Source.';
TWCC_NOTEMPTY: Result := 'Operation failed because directory is not empty.';
TWCC_OPERATIONERROR: Result := 'Source or Source Manager reported an error to the user and handled the error; no application action required.';
TWCC_PAPERJAM: Result := 'Transfer failed because of a feeder error';
TWCC_SEQERROR: Result := 'Illegal operation for current Source Manager Source state.';
TWCC_SUCCESS: Result := 'Operation worked.';
else
Result := 'Unknown Condition ' + IEIntToStr(rsl);
end;
end;
function IETW_DS(var grec: tgrec; dg: TW_UINT32; dat: TW_UINT16; msg: TW_UINT16; pd: TW_MEMREF): boolean;
var
fpExpDisabler: TIE8087ExceptionsDisabler;
begin
with grec do
begin
rc := TWRC_FAILURE;
if (@DSM_Entry <> nil) then
begin
try
fpExpDisabler := TIE8087ExceptionsDisabler.Create();
try
rc := DSM_Entry(@AppId, @SourceId, dg, dat, msg, pd);
finally
fpExpDisabler.Free();
end;
if (rc <> TWRC_SUCCESS) and (dat <> DAT_EVENT) and assigned(TWParams) then
begin
TWParams.LastError := rc;
TWParams.LastErrorStr := ResultToStr(rc);
LogWrite('IETW_DS : ' + TWParams.LastErrorStr);
end;
except
on E:Exception do
LogWrite('IETW_DS : Exception -> ' + AnsiString(E.Message));
end;
end;
result := (rc = TWRC_SUCCESS);
end;
end;
procedure Init_grec(var grec: tgrec);
begin
grec.actwnd := windows.GetActiveWindow;
grec.fAborting := false;
grec.nState := 1;
grec.TWParams := nil;
grec.BWToInvert := false;
grec.sending := false;
grec.uionly := false;
with grec.AppId do
begin
id := 0;
with version do
begin
MajorNum := 1;
MinorNum := 0;
Language := TWLG_USERLOCALE; // 3.0.3
Country := TWCY_USA;
Info := ' ' + #0;
end;
ProtocolMajor := TWON_PROTOCOLMAJOR;
ProtocolMinor := TWON_PROTOCOLMINOR;
SupportedGroups := DG_IMAGE or DG_CONTROL;
Manufacturer := ' ' + #0;
ProductFamily := ' ' + #0;
ProductName := ' ' + #0;
end;
grec.fWindowList := nil;
grec.NativePixelFormat := false;
end;
procedure GetCustomData(var grec: tgrec);
var
customData: TW_CUSTOMDSDATA;
dataPtr: pbyte;
begin
FillChar(customData, sizeof(TW_CUSTOMDSDATA), 0);
if IETW_DS(grec, DG_CONTROL, DAT_CUSTOMDSDATA, MSG_GET, @customData) and
(customData.InfoLength>0) and
(GlobalSize(customData.hData)>=customData.InfoLength) then
begin
dataPtr := GlobalLock(customData.hData);
try
grec.TWParams.SourceSettings.Clear;
grec.TWParams.SourceSettings.Write(pbyte(dataPtr)^, customData.InfoLength);
finally
GlobalUnlock(customData.hData);
GlobalFree(customData.hData);
end;
end;
end;
procedure SetCustomData(var grec: tgrec);
var
customData: TW_CUSTOMDSDATA;
dataSize: integer;
dataPtr: pbyte;
begin
dataSize := grec.TWParams.SourceSettings.Size;
if dataSize>0 then
begin
customData.InfoLength := dataSize;
customData.hData := GlobalAlloc(GHND, dataSize);
dataPtr := GlobalLock(customData.hData);
try
CopyMemory(dataPtr, grec.TWParams.SourceSettings.Memory, dataSize);
GlobalUnlock(customData.hData);
IETW_DS(grec, DG_CONTROL, DAT_CUSTOMDSDATA, MSG_SET, @customData);
finally
GlobalFree(customData.hData);
end;
end;
end;
procedure Set_AppId(var grec: tgrec);
begin
with grec.AppId do
begin
IEStrCopy(version.Info, PAnsiChar(grec.TWParams.AppVersionInfo)); // <?>
version.Info[33] := #0;
IEStrCopy(Manufacturer, PAnsiChar(grec.TWParams.AppManufacturer));
Manufacturer[33] := #0;
IEStrCopy(ProductFamily, PAnsiChar(grec.TWParams.AppProductFamily));
ProductFamily[33] := #0;
IEStrCopy(ProductName, PAnsiChar(grec.TWParams.AppProductName));
ProductName[33] := #0;
Version.Language := grec.TWParams.Language; // 3.0.3
Version.Country := grec.TWParams.Country; // 3.0.3
end;
end;
function IETW_LoadSourceManager(var grec: tgrec): boolean;
var
szSMDir: array[0..255] of AnsiChar;
cc: integer;
begin
with grec do
begin
LogWrite('IETW_LoadSourceManager');
if (nState >= 2) then
begin
LogWrite(' IETW_LoadSourceManager : already loaded');
result := TRUE; // DSM already loaded
exit;
end;
if PTwainShared^.hDSMLib <> 0 then
begin
hDSMLib := PTwainShared^.hDSMLib;
DSM_Entry := PTwainShared^.DSM_Entry;
result := TRUE;
nState := 2;
LogWrite(' IETW_LoadSourceManager : already loaded');
exit;
end;
GetWindowsDirectoryA(szSMDir, sizeof(szSMDir));
cc := lstrlenA(@szSMDir);
if (cc <> 0) and (szSMDir[cc - 1] <> ':') then
lstrcatA(@szSMDir, '\');
lstrcatA(@szSMDir, PAnsiChar(DSM_FILENAME));
hDSMLib := 0;
if IEFileExists(string(AnsiString(szSMDir))) then
hDSMLib := LoadLibraryA(szSMDir);
DSM_Entry := nil;
if hDSMLib <> 0 then
begin
LogWrite(' IETW_LoadSourceManager : Load OK');
DSM_Entry := TDSMEntryProc(GetProcAddress(hDSMLib, PAnsiChar(DSM_ENTRYPOINT)));
if @DSM_Entry <> nil then
begin
nState := 2;
end
else
begin
FreeLibrary(hDSMLib);
hDSMLib := 0;
end
end;
result := (nState >= 2);
PTwainShared^.hDSMLib := hDSMLib;
PTwainShared^.DSM_Entry := DSM_Entry;
end;
end;
// use Force=true to really unloadsourcemanager
function IETW_UnloadSourceManager(var grec: tgrec; force: boolean): boolean;
begin
with grec do
begin
LogWrite('IETW_UnloadSourceManager');
if force and (PTwainShared^.hDSMLib <> 0) then
begin
FreeLibrary(hDSMLib);
hDSMLib := 0;
DSM_Entry := nil;
PTwainShared^.hDSMLib := 0;
PTwainShared^.DSM_Entry := nil;
nState := 1;
LogWrite(' IETW_UnloadSourceManager : Unload OK');
end
else
if (nState = 2) then
begin
if (hDSMLib <> 0) then
hDSMLib := 0;
DSM_Entry := nil;
nState := 1;
LogWrite(' IETW_UnloadSourceManager not Unloaded, for future uses');
end;
result := (nState = 1);
end;
end;
function CreateProxyWindow(var grec: tgrec): HWND;
var
mainwnd: HWND;
begin
LogWrite('CreateProxyWindow');
if grec.PTwainShared.hproxy <> 0 then
begin
result := grec.PTwainShared^.hproxy;
LogWrite(' CreateProxyWindow : already created');
exit;
end;
{$IFDEF OCXVERSION}
mainwnd := HWND_DESKTOP;
{$ELSE}
mainwnd := grec.callwnd;
if mainwnd = 0 then
mainwnd := HWND_DESKTOP;
{$ENDIF}
{$WARNINGS OFF}
// Here memory debuggers could show a memory leak: it is not true, if DestroyWindow is not called by ImageEn
// it is called by parent window.
result := CreateWindow('STATIC', 'Acquire Proxy', WS_POPUPWINDOW, CW_USEDEFAULT, CW_USEDEFAULT,
CW_USEDEFAULT, CW_USEDEFAULT,
mainwnd, 0, GetModuleHandle(nil), nil);
if assigned(Application) then
Application.ProcessMessages;
grec.PTwainShared.hproxy := result;
LogWrite(' CreateProxyWindow : created');
{$WARNINGS ON}
end;
procedure DestroyProxyWindow(wnd: HWND; var grec: tgrec; force: boolean);
begin
LogWrite('DestroyProxyWindow');
if force then
begin
// the window could be destroyed by parent
if IsWindow(grec.PTwainShared^.hproxy) then
DestroyWindow(grec.PTwainShared.hproxy);
grec.PTwainShared.hproxy := 0;
LogWrite(' DestroyProxyWindow : destroyed');
end
else
begin
LogWrite(' DestroyProxyWindow : not destroyed, for future uses');
end;
end;
function IETW_Mgr(var grec: tgrec; dg: TW_UINT32; dat: TW_UINT16; msg: TW_UINT16; pd: TW_MEMREF): boolean;
var
fpExpDisabler: TIE8087ExceptionsDisabler;
begin
with grec do
begin
rc := TWRC_FAILURE;
if (@DSM_Entry <> nil) then
begin
try
fpExpDisabler := TIE8087ExceptionsDisabler.Create();
try
rc := DSM_Entry(@AppId, nil, dg, dat, msg, pd);
finally
fpExpDisabler.Free();
end;
if (rc <> TWRC_SUCCESS) and assigned(TWParams) then
begin
TWParams.LastError := rc;
TWParams.LastErrorStr := ResultToStr(rc);
LogWrite('IETW_Mgr : ' + TWParams.LastErrorStr);
end;
except
end;
end;
result := (rc = TWRC_SUCCESS);
end;
end;
function IETW_OpenSourceManager(var grec: tgrec; hwnd: HWND): boolean;
begin
with grec do
begin
LogWrite('IETW_OpenSourceManager');
hwndSM := hwnd;
if (IETW_Mgr(grec, DG_CONTROL, DAT_PARENT, MSG_OPENDSM, @hwndSM)) then
nState := TWAIN_SM_OPEN;
result := (nState >= TWAIN_SM_OPEN);
if result then
LogWrite(' IETW_OpenSourceManager : Ok')
else
LogWrite(' IETW_OpenSourceManager : FAILED!');
end;
end;
function IETW_CloseSourceManager(var grec: tgrec; hwnd: HWND): boolean;
var
hwnd32: TW_INT32;
begin
with grec do
begin
LogWrite('IETW_CloseSourceManager');
IETW_EmptyMessageQueue(grec);
hwnd32 := hwnd;
rc := TWRC_SUCCESS;
if (IETW_Mgr(grec, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, @hwnd32)) then
begin
nState := 2;
end;
result := (nState <= 2);
if result then
LogWrite(' IETW_CloseSourceManager : Ok')
else
LogWrite(' IETW_CloseSourceManager : FAILED!');
end;
end;
function IETW_DisableSource(var grec: tgrec): boolean;
begin
with grec do
begin
LogWrite('IETW_DisableSource');
BreakModalLoop := true;
if (nState = 5) then
begin
IETW_DS(grec, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, @twUI);
nState := 4;
end;
{$IFDEF IETWAINTASKWINDOWS}
if fWindowList <> nil then
EnableTaskWindows(fWindowList);
fWindowList := nil;
{$ENDIF}
IETW_EmptyMessageQueue(grec);
result := (nState <= 4);
if result then
LogWrite(' IETW_DisableSource : Ok')
else
LogWrite(' IETW_DisableSource : FAILED!');
end;
end;
function IETW_CloseSource(var grec: tgrec): boolean;
begin
with grec do
begin
LogWrite('IETW_CloseSource');
BreakModalLoop := true;
rc := TWRC_SUCCESS;
if (nState = 5) then
IETW_DisableSource(grec);
if (nState = 4) and (IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS, @SourceId)) then
nState := 3;
result := (nState <= 3);
if result then
LogWrite(' IETW_CloseSource : Ok')
else
LogWrite(' IETW_CloseSource : FAILED!');
end;
end;
// returns ProductName of selected source
function IETW_SelectImageSource(var SelectedSourceName: AnsiString; TwainShared: PIETwainShared; callwnd: HWND): boolean;
var
NewSourceId: TW_IDENTITY;
grec: tgrec;
wnd: HWND;
begin
result := false;
if IEGlobalSettings().IsInsideTwain then
exit;
IEGlobalSettings().IsInsideTwain := true;
try
Init_grec(grec);
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
if IEGlobalSettings().ModelessSelectTwainSource then
wnd := CreateProxyWindow(grec)
else
wnd := callwnd;
grec.proxywnd := wnd;
if IETW_LoadSourceManager(grec) then
begin
if IETW_OpenSourceManager(grec, wnd) then
begin
FillMemory(@NewSourceId, sizeof(NewSourceId), 0);
IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_GETDEFAULT, @NewSourceId);
// Post the Select Source dialog
result := IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT, @NewSourceId);
SelectedSourceName := NewSourceId.ProductName;
IETW_CloseSourceManager(grec, wnd);
end
else
begin
if wnd <> callwnd then
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
end;
if wnd <> callwnd then
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
finally
windows.SetActiveWindow(grec.actwnd);
IEGlobalSettings().IsInsideTwain := false;
end;
end;
procedure ClearError(var grec: tgrec);
begin
grec.nErrDetail := ED_NONE;
end;
function IETW_GetResultCode(var grec: tgrec): word;
begin
result := grec.rc;
end;
function IETW_GetConditionCode(var grec: tgrec): word;
var
twStatus: TW_STATUS;
begin
with grec do
begin
if nState >= 4 then
begin
// get source status if open
IETW_DS(grec, DG_CONTROL, DAT_STATUS, MSG_GET, TW_MEMREF(@twStatus));
end
else
if nState = 3 then
begin
// otherwise get source manager status
IETW_Mgr(grec, DG_CONTROL, DAT_STATUS, MSG_GET, TW_MEMREF(@twStatus));
end
else
begin
// nothing open, not a good time to get condition code!
result := TWCC_SEQERROR;
exit;
end;
if rc = TWRC_SUCCESS then
begin
result := twStatus.ConditionCode;
exit;
end
else
result := TWCC_BUMMER;
end;
end;
function RecordError(var grec: tgrec; ed: ErrorDetail): boolean;
begin
with grec do
begin
if nErrDetail = ED_NONE then
begin
nErrDetail := ed;
if (ed > ED_START_TRIPLET_ERRS) and (ed < ED_END_TRIPLET_ERRS) then
begin
nErrRC := IETW_GetResultCode(grec);
nErrCC := IETW_GetConditionCode(grec);
end
else
begin
nErrRC := 0;
nErrCC := 0;
end;
end;
result := FALSE;
end;
end;
function IETW_OpenSource(var grec: tgrec): boolean;
var
src: pTW_IDENTITY;
sn: AnsiString;
begin
with grec do
begin
LogWrite('IETW_OpenSource');
if (nState <> 3) then
begin
result := FALSE;
LogWrite(' IETW_OpenSource : already loaded');
exit;
end;
sn := TWParams.SourceName[TWParams.SelectedSource];
if sn <> '' then
begin
// Find selected source by ProductName
src := AllocMem(sizeof(TW_IDENTITY));
try
IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_GETFIRST, src);
while rc <> TWRC_ENDOFLIST do
begin
if src^.ProductName = sn then
break;
ZeroMemory(src, sizeof(TW_IDENTITY));
IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_GETNEXT, src);
end;
move(src^, SourceId, sizeof(TW_IDENTITY));
finally
FreeMem(src);
end;
end
else
begin
// system default source
SourceId.ProductName[0] := #0;
SourceId.Id := 0;
end;
if (IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, @SourceId)) then
begin
nState := 4;
SetCustomData(grec);
end
else
RecordError(grec, ED_DSM_FAILURE);
result := (nState = 4);
if result then
LogWrite(' IETW_OpenSource : Ok')
else
LogWrite(' IETW_OpenSource : FAILED!');
end;
end;
function IETW_EnableSource(var grec: tgrec; hwnd: HWND): boolean;
var
ActiveWindowHandle: Windows.HWND;
begin
with grec do
begin
LogWrite('IETW_EnableSource');
if (nState <> 4) then
begin
result := FALSE;
LogWrite(' IETW_EnableSource : already enabled');
exit;
end;
twUI.ShowUI := TWParams.VisibleDialog;;
twUI.hParent := TW_HANDLE(hwnd);
twUI.ModalUI := modal;
{$IFDEF IETWAINTASKWINDOWS}
ActiveWindowHandle := 0;
if assigned(Screen) and assigned(Screen.ActiveForm) and Screen.ActiveForm.HandleAllocated then
ActiveWindowHandle := Screen.ActiveForm.Handle;
fWindowList := DisableTaskWindows(ActiveWindowHandle);
{$ENDIF}
LogWrite(' IETW_EnableSource : ShowUI=' + IEIntToStr(integer(twUI.ShowUI)) + ' hParent=' + IEIntToStr(twUI.hParent) + ' ModalUI=' + IEIntToStr(integer(twUI.ModalUI)));
if uionly then
IETW_DS(grec, DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDSUIONLY, @twUI)
else
IETW_DS(grec, DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS, @twUI);
if (rc = TWRC_FAILURE) or (rc=TWCC_NODS) then
begin
RecordError(grec, ED_DS_FAILURE);
end
else
nState := 5;
result := (nState = 5);
if result then
LogWrite(' IETW_EnableSource : Ok')
else
LogWrite(' IETW_EnableSource : FAILED!');
end;
end;
function GetCapability(var grec: tgrec; var twCapability: TW_CAPABILITY; cap: TW_UINT16): boolean;
begin
twCapability.Cap := cap;
twCapability.ConType := TWON_DONTCARE16;
twCapability.hContainer := 0;
LogWrite('GetCapability : $' + IEIntToHex(cap, 4));
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_GET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
if result then
LogWrite(' GetCapability : Ok')
else
LogWrite(' GetCapability : FAILED!');
end;
function GetOneStringCapability(var grec: tgrec; outstr: AnsiString; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
ptr: PAnsiChar;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
pvalOneValue := GlobalLock(twCapability.hContainer);
ptr := @(pvalOneValue^.Item);
outstr := AnsiString(ptr);
GlobalUnlock(twCapability.hContainer);
GlobalFree(twCapability.hContainer);
end;
// Supported TW_ONEVALUE (current value)
function SetOneStringCapability(var grec: tgrec; value: AnsiString; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
ptr: PAnsiChar;
begin
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetOnStringCapability $' + IEIntToHex(cap, 4));
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
// write TW_ONEVALUE (current value only)
value := IECopy(value, 1, 255);
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE) + 256 - 4);
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_STR255;
ptr := @(pvalOneValue^.Item);
IEStrCopy(ptr, PAnsiChar(value));
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
if result then
LogWrite(' SetOnStringCapability : Ok')
else
LogWrite(' SetOnStringCapability : FAILED!')
end;
function IETW_AbortAllPendingXfers(var grec: tgrec): boolean;
begin
with grec do
begin
LogWrite('IETW_AbortAllPendingXfers');
breakmodalloop := true;
if (nState = 7) and IETW_DS(grec, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @pendingXfers) then
begin
if pendingXfers.Count <> 0 then
nState := 6
else
nState := 5;
end;
if (nState = 6) and (IETW_DS(grec, DG_CONTROL, DAT_PENDINGXFERS, MSG_RESET, @pendingXfers)) then
begin
nState := 5;
end;
IETW_EmptyMessageQueue(grec);
result := (nState <= 5);
if result then
LogWrite(' IETW_AbortAllPendingXfers : Ok')
else
LogWrite(' IETW_AbortAllPendingXfers : FAILED!')
end;
end;
// supported 1bit(black/write), 8bit(grayscale), 24bit(truecolor)
procedure CopyBuffer(var grec: tgrec; Bitmap: TIEBitmap; const twImageInfo: TW_IMAGEINFO; const imxfer: TW_IMAGEMEMXFER; LockMemory: boolean);
var
src, dst: pbyte; // source buffer
sinc: integer; // source row length DWORDed
pb: pbyte; // dest buffer
row, col: integer;
t1: integer;
px: PRGB;
pw, pxw: pword;
begin
{$WARNINGS OFF}
LogWrite('CopyBuffer compression=' + IEIntToStr(imxfer.Compression) + ' BytesPerRow=' + IEIntToStr(imxfer.BytesPerRow) + ' Columns=' + IEIntToStr(imxfer.Columns) + ' Rows=' +
IEIntToStr(imxfer.Rows) + ' XOffset=' + IEIntToStr(imxfer.XOffset) + ' YOffset=' + IEIntToStr(imxfer.YOffset) + ' BytesWritten=' + IEIntToStr(imxfer.BytesWritten));
if LockMemory then
src := GlobalLock(HGLOBAL(imxfer.Memory.TheMem)) // source data
else
src := imxfer.Memory.TheMem;
sinc := imxfer.BytesPerRow;
case twImageInfo.BitsPerPixel of
48:
// RGB 48 bit (16 bit per channel)
if grec.NativePixelFormat then
// native pixel format
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
dst := Bitmap.Scanline[t1];
inc(dst, imxfer.XOffset * 6); // select column
CopyMemory(dst, src, imxfer.Columns*6);
inc(src, sinc);
end
else
// convert to 24 bit
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
dst := Bitmap.Scanline[t1];
inc(dst, imxfer.XOffset * 3); // select column
px := PRGB(dst);
pw := pword(src);
for col := 0 to imxfer.Columns - 1 do
begin
px^.r := pw^ shr 8; inc(pw);
px^.g := pw^ shr 8; inc(pw);
px^.b := pw^ shr 8; inc(pw);
inc(px);
end;
inc(src, sinc);
end;
24:
// truecolor (24bit)
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
dst := Bitmap.Scanline[t1];
inc(dst, imxfer.XOffset * 3); // select column
_CopyBGR_RGB(PRGB(dst), PRGB(src), imxfer.Columns);
inc(src, sinc);
end;
16:
// 16 bit gray scale
if grec.NativePixelFormat then
begin
// native pixel format
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
pxw := Bitmap.Scanline[t1];
inc(pxw, imxfer.XOffset); // select column
pw := pword(src);
for col := 0 to imxfer.Columns - 1 do
begin
pxw^ := pw^;
inc(pxw);
inc(pw);
end;
inc(src, sinc);
end;
end
else
// convert to 24 bit
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
dst := Bitmap.Scanline[t1];
inc(dst, imxfer.XOffset * 3); // select column
pw := pword(src);
px := PRGB(dst);
for col := 0 to imxfer.Columns - 1 do
begin
with px^ do
begin
r := pw^ shr 8;
g := r;
b := r;
end;
inc(pw);
inc(px);
end;
inc(src, sinc);
end;
8:
// grayscale (8bit)
if grec.NativePixelFormat then
begin
// native pixel format
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
dst := Bitmap.Scanline[t1];
inc(dst, imxfer.XOffset); // select column
pb := src;
for col := 0 to imxfer.Columns - 1 do
begin
dst^ := pb^;
inc(pb);
inc(dst);
end;
inc(src, sinc);
end;
end
else
// convert to 24 bit
for row := 0 to imxfer.Rows - 1 do
begin
t1 := row + imxfer.YOffset;
if t1 >= Bitmap.Height then
break;
dst := Bitmap.Scanline[t1];
inc(dst, imxfer.XOffset * 3); // select column
pb := src;
px := PRGB(dst);
for col := 0 to imxfer.Columns - 1 do
begin
with px^ do
begin
r := pb^;
g := pb^;
b := pb^;
end;
inc(pb);
inc(px);
end;
inc(src, sinc);
end;
1:
begin
// black/write (1bit)
for row := 0 to imxfer.Rows - 1 do
begin
dst := Bitmap.Scanline[row + imxfer.YOffset];
IECopyBits_large(dst, src, imxfer.XOffset, 0, imxfer.Columns, 2147483647);
inc(src, sinc);
end;
end;
end;
if LockMemory then
GlobalUnlock(HGLOBAL(imxfer.Memory.TheMem));
LogWrite('CopyBuffer : Ok');
{$WARNINGS ON}
end;
function GetOneBool(var grec: tgrec; var Value: boolean; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pbol: pTW_BOOL;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
if twCapability.ConType = TWON_ONEVALUE then
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
pbol := @(pvalOneValue^.Item);
Value := pbol^;
GlobalUnlock(twCapability.hContainer);
end
else
result := false;
GlobalFree(twCapability.hContainer);
end;
function GetOneUINT16(var grec: tgrec; var Value: integer; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
puint16: pTW_UINT16;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
if twCapability.ConType = TWON_ONEVALUE then
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
puint16 := @(pvalOneValue^.Item);
Value := puint16^;
GlobalUnlock(twCapability.hContainer);
end
else
result := false;
GlobalFree(twCapability.hContainer);
end;
function GetOneINT16(var grec: tgrec; var Value: integer; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pint16: pTW_INT16;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
if twCapability.ConType = TWON_ONEVALUE then
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
pint16 := @(pvalOneValue^.Item);
Value := pint16^;
GlobalUnlock(twCapability.hContainer);
end
else
result := false;
GlobalFree(twCapability.hContainer);
end;
function GetOneINT32(var grec: tgrec; var Value: integer; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pint32: pTW_INT32;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
if twCapability.ConType = TWON_ONEVALUE then
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
pint32 := @(pvalOneValue^.Item);
Value := pint32^;
GlobalUnlock(twCapability.hContainer);
end
else
result := false;
GlobalFree(twCapability.hContainer);
end;
// Supported TW_ONEVALUE (current value)
function SetOneBoolCapability(var grec: tgrec; value: boolean; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
begin
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
// write TW_ONEVALUE (current value only)
LogWrite('SetOnBoolCapability');
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_BOOL;
pvalOneValue^.Item := ord(value);
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
if result then
LogWrite(' SetOnBoolCapability : Ok')
else
LogWrite(' SetOnBoolCapability : FAILED!');
end;
procedure settemppath(os: PAnsiChar);
var
s: AnsiString;
begin
s := AnsiString(IEGetTempFileName2+'.bmp');
if length(s) > 254 then
s := AnsiString(IEGlobalSettings().DefTEMPPATH) + 'imageentwain03.bmp';
if length(s) > 254 then
s := 'imageentwain03.bmp';
IEStrCopy(os, PAnsiChar(s));
end;
procedure IETW_XferReady(var grec: tgrec; pmsg: PMSG);
var
hNative: TW_UINT32;
setupmemxfer: TW_SETUPMEMXFER;
setupfilexfer: TW_SETUPFILEXFER;
imxfer: TW_IMAGEMEMXFER;
hbuff: THandle;
twImageInfo: TW_IMAGEINFO;
pimxfer: pTW_IMAGEMEMXFER;
DelayImageInfo: boolean; // if true recall ImageInfo after loaded all buffers
buffers: TList;
ptr: pointer;
i: integer;
pixfor: TIEPixelFormat;
io: TImageEnIO;
XFerBufferSize: dword;
lrc: TW_INT16;
function ImageInfo(): boolean;
begin
LogWrite('IETW_XferReady.ImageInfo');
DelayImageInfo := false;
result := true;
try
with grec do
begin
if not IETW_DS(grec, DG_IMAGE, DAT_IMAGEINFO, MSG_GET, TW_MEMREF(@twImageInfo)) then
begin
IETW_AbortAllPendingXfers(grec);
result := false;
LogWrite('IETW_XferReady.ImageInfo : not available!');
exit;
end;
if (TransferMode <> tmFile) and ((twImageInfo.PixelType > 2) or (twImageInfo.Planar <> false) or (twImageInfo.Compression <> 0)) then
TransferMode := tmNative;
case twImageInfo.BitsPerPixel of
1..8:
begin
IOParams.BitsPerSample := twImageInfo.BitsPerPixel;
IOParams.SamplesPerPixel := 1;
end;
24:
begin
IOParams.BitsPerSample := 8;
IOParams.SamplesPerPixel := 3;
end;
48:
begin
IOParams.BitsPerSample := 8;
IOParams.SamplesPerPixel := 4;
end;
end;
IOParams.DpiX := round(twImageInfo.XResolution.Whole + twImageInfo.XResolution.Frac / 65536);
IOParams.DpiY := round(twImageInfo.YResolution.Whole + twImageInfo.YResolution.Frac / 65536);
IOParams.Width := twImageInfo.ImageWidth;
IOParams.Height := twImageInfo.ImageLength;
IOParams.OriginalWidth := twImageInfo.ImageWidth;
IOParams.OriginalHeight := twImageInfo.ImageLength;
IOParams.FreeColorMap;
if (IOParams.Width < 0) or (IOParams.Height < 0) then
begin
DelayImageInfo := true;
result := true;
exit;
end;
if (IOParams.Width = 0) or (IOParams.Height = 0) then
begin
IETW_AbortAllPendingXfers(grec);
result := false;
exit;
end;
if NativePixelFormat then
begin
case twImageInfo.BitsPerPixel of
1: pixfor := ie1g;
8: pixfor := ie8g;
16: pixfor := ie16g;
24: pixfor := ie24RGB;
48: pixfor := ie48RGB;
end;
end
else
begin
if (IOParams.BitsPerSample = 1) and (IOParams.SamplesPerPixel = 1) then
pixfor := ie1g
else
pixfor := ie24RGB;
end;
if (fBitmap.Width <> IOParams.Width) or (fBitmap.Height <> IOParams.Height) or (fBitmap.PixelFormat <> pixfor) then
fBitmap.allocate(IOParams.Width, IOParams.Height, pixfor);
end;
except
LogWrite(' IETW_XferReady.ImageInfo : exception!');
if result then
begin
IETW_AbortAllPendingXfers(grec);
result := false;
end;
end;
LogWrite(' IETW_XferReady.ImageInfo : end');
end;
procedure AllocXFerBuffer(bufsize: dword);
begin
XFerBufferSize := dwmax(setupmemxfer.Preferred, bufsize);
hbuff := GlobalAlloc(GPTR, XFerBufferSize);
with imxfer do
begin
Compression := TWON_DONTCARE16;
BytesPerRow := TW_UINT32(TWON_DONTCARE32);
Columns := TW_UINT32(TWON_DONTCARE32);
Rows := TW_UINT32(TWON_DONTCARE32);
XOffset := TW_UINT32(TWON_DONTCARE32);
YOffset := TW_UINT32(TWON_DONTCARE32);
BytesWritten := TW_UINT32(TWON_DONTCARE32);
Memory.Length := XFerBufferSize;
if grec.TWParams.UseMemoryHandle then
begin
Memory.Flags := TWMF_APPOWNS or TWMF_HANDLE;
Memory.TheMem := pointer(hbuff);
end
else
begin
Memory.Flags := TWMF_APPOWNS or TWMF_POINTER;
Memory.TheMem := GlobalLock(hbuff);
end;
end;
end;
procedure FreeXFerBuffer();
begin
if not grec.TWParams.UseMemoryHandle then
GlobalUnlock(hbuff);
GlobalFree(hbuff);
end;
begin
{$WARNINGS OFF}
LogWrite('IETW_XferReady');
with grec do
begin
if not ImageInfo then
begin
fAborting := true;
LogWrite('IETW_XferReady : ABORTED, image info not available!');
exit;
end;
//DelayImageInfo := true; // uncomment to force undefined size (test only)
case TransferMode of
tmBuffered:
begin
///// Buffered xfer
LogWrite(' IETW_XferReady : buffered transfer mode');
buffers := nil;
if DelayImageInfo then
buffers := TList.Create;
if assigned(Progress) and (twImageInfo.ImageLength <> 0)then
Progress.per1 := 100 / twImageInfo.ImageLength;
if IETW_DS(grec, DG_CONTROL, DAT_SETUPMEMXFER, MSG_GET, @setupmemxfer) then
LogWrite(' IETW_XferReady : DAT_SETUPMEMXFER Ok')
else
LogWrite(' IETW_XferReady : DAT_SETUPMEMXFER FAILED!');
AllocXFerBuffer(IEGlobalSettings().TwainTransferBufferSize);
try
repeat
if IETW_DS(grec, DG_IMAGE, DAT_IMAGEMEMXFER, MSG_GET, @imxfer) then
LogWrite(' IETW_XferReady : DAT_IMAGEMEMXFER Ok')
else
LogWrite(' IETW_XferReady : DAT_IMAGEMEMXFER FAILED! (image terminated?)');
lrc := rc; // next call to IETW_GetConditionCode() changes current rc
if (rc = TWRC_FAILURE) and
(IETW_GetConditionCode(grec) = TWCC_BADVALUE) and
(XFerBufferSize <> setupmemxfer.Preferred) then
begin
// bad xfer buffer size, realloc with preferred buffer size
FreeXFerBuffer();
AllocXFerBuffer(setupmemxfer.Preferred);
continue;
end;
rc := lrc;
case rc of
TWRC_SUCCESS, TWRC_XFERDONE:
begin
if rc = TWRC_SUCCESS then
LogWrite(' IETW_XferReady : TWRC_SUCCESS begin');
if rc = TWRC_XFERDONE then
LogWrite(' IETW_XferReady : TWRC_XFERDONE begin');
if DelayImageInfo then
begin
new(pimxfer);
move(imxfer, pimxfer^, sizeof(TW_IMAGEMEMXFER));
getmem(pimxfer^.Memory.TheMem, imxfer.BytesWritten);
ptr := GlobalLock(HGLOBAL(imxfer.Memory.TheMem));
CopyMemory(pimxfer^.Memory.TheMem, ptr, imxfer.BytesWritten);
GlobalUnlock(HGLOBAL(imxfer.Memory.TheMem));
buffers.Add(pimxfer);
end
else
CopyBuffer(grec, fBitmap, twImageInfo, imxfer, true);
if rc = TWRC_XFERDONE then
begin
// CAP_CAPTION
//if not GetOneStringCapability(grec, IOParams.FileName, CAP_CAPTION) then // 4.1.0 beta
IOParams.FileName := '';
//
nState := 7;
transferdone := true;
if DelayImageInfo then
begin
// get image info and copy buffers
if ImageInfo then
begin
for i := 0 to buffers.Count - 1 do
begin
pimxfer := buffers[i];
CopyBuffer(grec, fBitmap, twImageInfo, pimxfer^, false);
end;
end;
DelayImageInfo := true; // this because ImageInfo set it to False
// are there other transfers?
if (nState = 7) and IETW_DS(grec, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @pendingXfers) then
begin
if pendingXfers.Count <> 0 then
nState := 6
else
nState := 5;
end;
end;
//
break;
end;
LogWrite(' IETW_XferReady : TWRC_SUCCESS or TWRC_XFERDONE end');
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReady : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
fAborting := true;
break;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReady : TWRC_FAILURE');
nState := 6;
fAborting := true;
break;
end;
end;
// OnProgress
if assigned(Progress) then
begin
with Progress^ do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * (imxfer.YOffset + imxfer.Rows)));
if Progress^.Aborting^ then
begin
nState := 7;
fAborting := true;
break;
end;
end;
until false;
finally
FreeXFerBuffer();
end;
if DelayImageInfo then
begin
for i := 0 to buffers.Count-1 do
begin
pimxfer := buffers[i];
freemem(pimxfer^.Memory.TheMem);
dispose(pimxfer);
end;
FreeAndNil(buffers);
end;
end;
tmNative:
begin
////// Native xfer
LogWrite(' IETW_XferReady : Native transfer mode');
IETW_DS(grec, DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hNative);
case (rc) of
TWRC_XFERDONE:
begin
// copy image
LogWrite(' IETW_XferReady : TWRC_XFERDONE');
if DelayImageInfo then
begin
if ImageInfo() then
_CopyDIB2BitmapEx(hNative, fBitmap, nil, false);
DelayImageInfo := true;
end
else
_CopyDIB2BitmapEx(hNative, fBitmap, nil, false);
GlobalFree(hNative);
//
nState := 7;
transferdone := true;
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReady : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
fAborting := true;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReady : TWRC_FAILURE');
nState := 6;
fAborting := true;
end;
else
nState := 6;
end;
end;
tmFile:
begin
////// File xfer
LogWrite(' IETW_XferReady : File transfer mode');
IETW_DS(grec, DG_CONTROL, DAT_SETUPFILEXFER, MSG_GET, @setupfilexfer);
settemppath(@setupfilexfer.FileName[0]);
if (setupfilexfer.Format = 1) or (setupfilexfer.Format = 3) or (setupfilexfer.Format = 5) or (setupfilexfer.Format = 6) or (setupfilexfer.Format > 7) then
setupfilexfer.Format := TWFF_BMP;
setupfilexfer.VRefNum := 0;
IETW_DS(grec, DG_CONTROL, DAT_SETUPFILEXFER, MSG_SET, @setupfilexfer);
IETW_DS(grec, DG_IMAGE, DAT_IMAGEFILEXFER, MSG_GET, nil);
case (rc) of
TWRC_XFERDONE:
begin
// copy image
LogWrite(' IETW_XferReady : TWRC_XFERDONE');
io := TImageEnIO.CreateFromBitmap(fBitmap);
try
io.LoadFromFile(setupfilexfer.FileName, FindFileFormat(setupfilexfer.FileName, ffContentOnly));
finally
FreeAndNil(io);
end;
DeleteFile( setupfilexfer.FileName );
//
nState := 7;
transferdone := true;
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReady : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
fAborting := true;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReady : TWRC_FAILURE');
nState := 6;
fAborting := true;
end;
else
nState := 6;
end;
end;
end;
breakmodalloop := true;
IETW_AbortAllPendingXfers(grec);
end;
LogWrite(' IETW_XferReady : end');
{$WARNINGS ON}
end;
procedure IETW_XferReadyMulti(var grec: tgrec; pmsg: PMSG);
var
hNative: TW_UINT32;
setupmemxfer: TW_SETUPMEMXFER;
setupfilexfer: TW_SETUPFILEXFER;
imxfer: TW_IMAGEMEMXFER;
hbuff: THandle;
twImageInfo: TW_IMAGEINFO;
ofy: integer;
ofy_set: boolean;
pimxfer: pTW_IMAGEMEMXFER;
DelayImageInfo: boolean; // if true recall ImageInfo after loaded all buffers
buffers: TList;
ptr: pointer;
i: integer;
fCaption: AnsiString;
io: TImageEnIO;
pixfor: TIEPixelFormat;
ImDpiX, ImDpiY: integer;
cper, lper: integer;
XFerBufferSize: dword;
lrc: TW_INT16;
condCode: word;
function ImageInfo(): boolean;
begin
LogWrite('IETW_XferReadyMulti.ImageInfo');
DelayImageInfo := false;
result := true;
try
with grec do
begin
if not IETW_DS(grec, DG_IMAGE, DAT_IMAGEINFO, MSG_GET, TW_MEMREF(@twImageInfo)) then
begin
IETW_AbortAllPendingXfers(grec);
result := false;
LogWrite('IETW_XferReadyMulti.ImageInfo : not available!');
exit;
end;
if (TransferMode <> tmFile) and ((twImageInfo.PixelType > 2) or (twImageInfo.Planar <> false) or (twImageInfo.Compression <> 0)) then
TransferMode := tmNative;
if (twImageInfo.ImageWidth < 0) or (twImageInfo.ImageLength < 0) then
begin
DelayImageInfo := true;
result := true;
exit;
end;
if (twImageInfo.ImageWidth <= 0) or (twImageInfo.ImageLength <= 0) then
begin
IETW_AbortAllPendingXfers(grec);
result := false;
exit;
end;
fBitmap := TIEBitmap.Create;
if NativePixelFormat then
begin
case twImageInfo.BitsPerPixel of
1: pixfor := ie1g;
8: pixfor := ie8g;
16: pixfor := ie16g;
24: pixfor := ie24RGB;
48: pixfor := ie48RGB;
end;
end
else
begin
if twImageInfo.BitsPerPixel = 1 then
pixfor := ie1g
else
pixfor := ie24RGB;
end;
fBitmap.Allocate(twImageInfo.ImageWidth, twImageInfo.ImageLength, pixfor)
end;
except
LogWrite(' IETW_XferReadyMulti.ImageInfo : exception!');
if result then
begin
IETW_AbortAllPendingXfers(grec);
result := false;
end;
end;
LogWrite(' IETW_XferReadyMulti.ImageInfo : end');
end;
procedure AllocXFerBuffer(bufsize: dword);
begin
XFerBufferSize := dwmax(setupmemxfer.Preferred, bufsize);
hbuff := GlobalAlloc(GPTR, XFerBufferSize);
with imxfer do
begin
Compression := TWON_DONTCARE16;
BytesPerRow := TW_UINT32(TWON_DONTCARE32);
Columns := TW_UINT32(TWON_DONTCARE32);
Rows := TW_UINT32(TWON_DONTCARE32);
XOffset := TW_UINT32(TWON_DONTCARE32);
YOffset := TW_UINT32(TWON_DONTCARE32);
BytesWritten := TW_UINT32(TWON_DONTCARE32);
Memory.Length := XFerBufferSize;
if grec.TWParams.UseMemoryHandle then
begin
Memory.Flags := TWMF_APPOWNS or TWMF_HANDLE;
Memory.TheMem := pointer(hbuff);
end
else
begin
Memory.Flags := TWMF_APPOWNS or TWMF_POINTER;
Memory.TheMem := GlobalLock(hbuff);
end;
end;
end;
procedure FreeXFerBuffer();
begin
if not grec.TWParams.UseMemoryHandle then
GlobalUnlock(hbuff);
GlobalFree(hbuff);
end;
begin
{$WARNINGS OFF}
LogWrite('IETW_XferReadyMulti');
fCaption := '';
with grec do
begin
repeat
LogWrite(' IETW_XferReadyMulti : getting another image');
if assigned(Progress) and Progress^.Aborting^ then
begin
LogWrite('IETW_XferReadyMulti, ending : Aborting = true!');
nState := 5; // 3.0.4
IETW_AbortAllPendingXfers(grec);
exit;
end;
if not ImageInfo or fAborting then
begin
LogWrite('IETW_XferReadyMulti, ending : ABORTED, image info not available!');
nState := 5; // 3.0.4
fAborting := true;
exit;
end;
//DelayImageInfo := true; // uncomment for force undefined size (test only)
case TransferMode of
tmBuffered:
begin
///// Buffered xfer
LogWrite(' IETW_XferReadyMulti : buffered transfer mode');
buffers := nil;
if DelayImageInfo then
buffers := TList.Create;
if IETW_DS(grec, DG_CONTROL, DAT_SETUPMEMXFER, MSG_GET, @setupmemxfer) then
LogWrite(' IETW_XferReadyMulti : DAT_SETUPMEMXFER Ok')
else
LogWrite(' IETW_XferReadyMulti : DAT_SETUPMEMXFER FAILED!');
AllocXFerBuffer(IEGlobalSettings().TwainTransferBufferSize);
try
if assigned(Progress) and (twImageInfo.ImageLength <> 0) then
Progress.per1 := 100 / twImageInfo.ImageLength;
lper := -1;
ofy_set := false;
ofy := 0;
repeat
if IETW_DS(grec, DG_IMAGE, DAT_IMAGEMEMXFER, MSG_GET, @imxfer) then
LogWrite(' IETW_XferReadyMulti : DAT_IMAGEMEMXFER Ok')
else
LogWrite(' IETW_XferReadyMulti : DAT_IMAGEMEMXFER FAILED! (image terminated?)');
if (rc = TWRC_FAILURE) then
begin
lrc := rc; // next call to IETW_GetConditionCode() changes current rc
condCode := IETW_GetConditionCode(grec);
if (condCode = TWCC_BADVALUE) and (XFerBufferSize <> setupmemxfer.Preferred) then
begin
// bad xfer buffer size, realloc with preferred buffer size
FreeXFerBuffer();
AllocXFerBuffer(setupmemxfer.Preferred);
continue;
end
// warning: experimental feature
else if (condCode = TWCC_NOMEDIA) or (condCode = TWCC_PAPERDOUBLEFEED) or (condCode = TWCC_PAPERJAM) then
begin
// force to cancel
rc := TWRC_CANCEL;
end
else
rc := lrc;
end;
if not ofy_set then
begin
ofy_set := true;
ofy := imxfer.YOffset;
end;
imxfer.YOffset := imxfer.YOffset - ofy;
case rc of
TWRC_SUCCESS, TWRC_XFERDONE:
begin
if rc = TWRC_SUCCESS then
LogWrite(' IETW_XferReadyMulti : TWRC_SUCCESS begin');
if rc = TWRC_XFERDONE then
LogWrite(' IETW_XferReadyMulti : TWRC_XFERDONE begin');
if DelayImageInfo then
begin
new(pimxfer);
move(imxfer, pimxfer^, sizeof(TW_IMAGEMEMXFER));
getmem(pimxfer^.Memory.TheMem, imxfer.BytesWritten);
ptr := GlobalLock(HGLOBAL(imxfer.Memory.TheMem));
CopyMemory(pimxfer^.Memory.TheMem, ptr, imxfer.BytesWritten);
GlobalUnlock(HGLOBAL(imxfer.Memory.TheMem));
buffers.Add(pimxfer);
end
else
begin
CopyBuffer(grec, fBitmap, twImageInfo, imxfer, true);
end;
if rc = TWRC_XFERDONE then
begin
// CAP_CAPTION
if not GetOneStringCapability(grec, fCaption, CAP_CAPTION) then
fCaption := '';
//
transferdone := true;
nState := 7;
if DelayImageInfo then
begin
// get image info and copy buffers
if ImageInfo then
begin
for i := 0 to buffers.Count - 1 do
begin
pimxfer := buffers[i];
CopyBuffer(grec, fBitmap, twImageInfo, pimxfer^, false);
end;
end;
DelayImageInfo := true; // this because ImageInfo set it to False
// are there other images?
if (nState = 7) and IETW_DS(grec, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @pendingXfers) then
begin
if pendingXfers.Count <> 0 then
nState := 6
else
nState := 5;
end;
end;
break;
end;
LogWrite(' IETW_XferReadyMulti : TWRC_SUCCESS or TWRC_XFERDONE end');
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
fAborting := true;
break;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_FAILURE');
nState := 6;
fAborting := true;
// version 2.1.6-3
if assigned(Progress) then
Progress^.Aborting^ := true;
//
break;
end;
end;
// OnProgress
if assigned(Progress) and assigned(Progress^.fOnProgress) then
begin
cper := trunc(Progress^.per1 * (imxfer.YOffset + imxfer.Rows));
if cper <> lper then
begin
Progress^.fOnProgress(Progress^.Sender, cper);
lper := cper;
end;
end;
until false;
finally
FreeXFerBuffer();
end;
if DelayImageInfo then
begin
for i := 0 to buffers.Count-1 do
begin
pimxfer := buffers[i];
freemem(pimxfer^.Memory.TheMem);
dispose(pimxfer);
end;
FreeAndNil(buffers);
end;
end;
tmNative:
begin
////// Native xfer
LogWrite(' IETW_XferReadyMulti : Native transfer mode');
IETW_DS(grec, DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hNative);
case (rc) of
TWRC_XFERDONE:
begin
// copy image
LogWrite(' IETW_XferReadyMulti : TWRC_XFERDONE');
if DelayImageInfo then
begin
if ImageInfo() then
_CopyDIB2BitmapEx(hNative, fBitmap, nil, false);
DelayImageInfo := true;
end
else
_CopyDIB2BitmapEx(hNative, fBitmap, nil, false);
GlobalFree(hNative);
//
nState := 7;
transferdone := true;
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
fAborting := true;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_FAILURE');
nState := 6;
fAborting := true;
end;
else
nState := 6;
end;
end;
tmFile:
begin
////// File xfer
LogWrite(' IETW_XferReadyMulti : File transfer mode');
IETW_DS(grec, DG_CONTROL, DAT_SETUPFILEXFER, MSG_GET, @setupfilexfer);
settemppath(@setupfilexfer.FileName[0]);
if (setupfilexfer.Format = 1) or (setupfilexfer.Format = 3) or (setupfilexfer.Format = 5) or (setupfilexfer.Format = 6) or (setupfilexfer.Format > 7) then
setupfilexfer.Format := TWFF_BMP;
setupfilexfer.VRefNum := 0;
IETW_DS(grec, DG_CONTROL, DAT_SETUPFILEXFER, MSG_SET, @setupfilexfer);
IETW_DS(grec, DG_IMAGE, DAT_IMAGEFILEXFER, MSG_GET, nil);
case (rc) of
TWRC_XFERDONE:
begin
// copy image
LogWrite(' IETW_XferReadyMulti : TWRC_XFERDONE');
io := TImageEnIO.CreateFromBitmap(fBitmap);
try
io.LoadFromFile(setupfilexfer.FileName, FindFileFormat(setupfilexfer.FileName, ffContentOnly));
finally
FreeAndNil(io);
end;
DeleteFile( setupfilexfer.FileName );
nState := 7;
transferdone := true;
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
fAborting := true;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_FAILURE');
nState := 6;
fAborting := true;
end;
else
nState := 6;
end;
end;
end;
if assigned(fBitmap) and (fBitmap.PixelFormat = ie1g) and grec.BWToInvert then
_Negative1BitEx(fBitmap);
ImDpiX := round(twImageInfo.XResolution.Whole + twImageInfo.XResolution.Frac / 65536);
ImDpiY := round(twImageInfo.YResolution.Whole + twImageInfo.YResolution.Frac / 65536);
if not fAborting then
MultiCallBack(fBitmap, TObject(IOParams), ImDpiX, ImDpiY);
FreeAndNil(fBitmap);
if IOParams <> nil then
begin
case twImageInfo.BitsPerPixel of
1..8:
begin
IOParams.BitsPerSample := twImageInfo.BitsPerPixel;
IOParams.SamplesPerPixel := 1;
end;
24:
begin
IOParams.BitsPerSample := 8;
IOParams.SamplesPerPixel := 3;
end;
end;
IOParams.DpiX := ImDpiX;
IOParams.DpiY := ImDpiY;
IOParams.Width := twImageInfo.ImageWidth;
IOParams.Height := twImageInfo.ImageLength;
IOParams.OriginalWidth := twImageInfo.ImageWidth;
IOParams.OriginalHeight := twImageInfo.ImageLength;
IOParams.FreeColorMap;
IOParams.FileName := fCaption;
end;
if (nState = 7) and IETW_DS(grec, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, @pendingXfers) then
begin
if pendingXfers.Count <> 0 then
nState := 6
else
nState := 5;
end;
until nState <> 6;
breakmodalloop := true;
IETW_AbortAllPendingXfers(grec);
end;
LogWrite(' IETW_XferReadyMulti : end');
{$WARNINGS ON}
end;
// true msg processed
function IETW_MessageHook(var grec: tgrec; lpmsg: pMSG): boolean;
var
bProcessed: boolean;
twEvent: TW_EVENT;
xmodal: boolean;
begin
LogWrite('IETW_MessageHook');
with grec do
begin
xmodal := modal; // grec.modal could not be more valid after ProxyWin.Free
bProcessed := FALSE;
if (nState >= 5) then
begin
// source enabled
LogWrite('IETW_MessageHook : state>=5');
twEvent.pEvent := TW_MEMREF(lpmsg);
twEvent.TWMessage := MSG_NULL;
IETW_DS(grec, DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT, @twEvent);
LogWrite('IETW_MessageHook : event.msg=$' + IEIntToHex(twEvent.TWMessage, 4));
bProcessed := (rc = TWRC_DSEVENT);
case (twEvent.TWMessage) of
MSG_XFERREADY:
begin
if not sending then
begin
sending := true;
nState := 6;
if gmulti then
IETW_XferReadyMulti(grec, lpmsg)
else
IETW_XferReady(grec, lpmsg);
if fAborting then
IETW_DisableSource(grec);
sending := false;
LogWrite(' IETW_MessageHook : processed MSG_XFERREADY');
end;
end;
MSG_CLOSEDSREQ:
begin
LogWrite(' IETW_MessageHook : processed MSG_CLOSEDSREQ');
IETW_DisableSource(grec);
if not xmodal then
FreeAndNil(grec.ProxyWin);
end;
MSG_CLOSEDSOK:
begin
LogWrite(' IETW_MessageHook : processed MSG_CLOSEDSOK');
closedsok := true;
IETW_DisableSource(grec);
GetCustomData(grec);
if not xmodal then
FreeAndNil(grec.ProxyWin);
end;
MSG_NULL:
begin
// no message returned from DS
LogWrite(' IETW_MessageHook : MSG_NULL');
end;
end;
end
else
LogWrite('IETW_MessageHook : state = ' + AnsiString(IntToStr(nState)));
result := bProcessed;
end;
if xmodal then
LogWrite('IETW_MessageHook : end');
end;
procedure IETW_EmptyMessageQueue(var grec: tgrec);
var
msg: TMSG;
begin
LogWrite('IETW_EmptyMessageQueue');
with grec do
begin
while (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) do
begin
if (msg.message = WM_QUIT) then
begin
PostQuitMessage(msg.wParam);
break;
end;
if (not IETW_MessageHook(grec, @msg)) then
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
end;
LogWrite(' IETW_EmptyMessageQueue : end');
end;
procedure IETW_ModalEventLoop(var grec: tgrec);
var
msg: TMSG;
begin
LogWrite('IETW_ModalEventLoop');
with grec do
begin
BreakModalLoop := false;
while (nState >= 5) and (not TransferDone) and (not BreakModalLoop) and (GetMessage(msg, 0, 0, 0)) do
begin
LogWrite('IETW_ModalEventLoop : event.msg=$' + IEIntToHex(msg.message, 4));
if (not IETW_MessageHook(grec, @msg)) then
begin
TranslateMessage(msg);
try
DispatchMessage(msg);
except
end;
end;
end;
BreakModalLoop := false;
end;
LogWrite('IETW_ModalEventLoop : end');
end;
function IETW_GetSourceList(SList: TList; TwainShared: PIETwainShared; callwnd: HWND): boolean;
var
SourceId: pTW_IDENTITY;
grec: tgrec;
wnd: HWND;
begin
result := false;
if IEGlobalSettings().IsInsideTwain then
exit;
IEGlobalSettings().IsInsideTwain := true;
try
SList.Clear;
Init_grec(grec);
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
wnd := CreateProxyWindow(grec);
grec.proxywnd := wnd;
if (IETW_LoadSourceManager(grec)) then
begin
if (IETW_OpenSourceManager(grec, wnd)) then
begin
SourceId := AllocMem(sizeof(TW_IDENTITY));
try
IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_GETFIRST, SourceId);
while grec.rc <> TWRC_ENDOFLIST do
begin
if SourceId^.ProductName = '' then
freemem(SourceId)
else
SList.Add(SourceId);
SourceId := AllocMem(sizeof(TW_IDENTITY));
IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_GETNEXT, SourceId);
end;
finally
FreeMem(SourceId); // last not assigned
end;
IETW_CloseSourceManager(grec, wnd);
result := true;
end
else
begin
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
end
else
begin
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
finally
windows.SetActiveWindow(grec.actwnd);
IEGlobalSettings().IsInsideTwain := false;
end;
end;
procedure FloatToFix32(const floater: double; fix32: pTW_FIX32);
var
s: double;
value: TW_INT32;
begin
try
if floater < 0 then
s := -0.5
else
s := 0.5;
value := trunc(floater * 65536 + s);
Fix32^.Whole := value shr 16;
Fix32^.Frac := value and $0000FFFF;
except
Fix32^.Whole := 0;
Fix32^.Frac := 0;
end;
end;
procedure GetAcquireFrame(var grec: tgrec; var fAcquireFrame: TIEDRect);
var
ImageLayout: TW_IMAGELAYOUT;
begin
LogWrite('GetAcquireFrame');
IETW_DS(grec, DG_IMAGE, DAT_IMAGELAYOUT, MSG_GET, @ImageLayout);
if grec.rc = TWRC_SUCCESS then
begin
with ImageLayout.Frame do
begin
fAcquireFrame.Left := Left.Whole + Left.Frac / 65536;
fAcquireFrame.Top := Top.Whole + Top.Frac / 65536;
fAcquireFrame.Right := Right.Whole + Right.Frac / 65536;
fAcquireFrame.Bottom := Bottom.Whole + BOttom.Frac / 65536;
end;
LogWrite(' GetAcquireFrame : ok');
end
else
begin
LogWrite(' GetAcquireFrame : FAILED!');
end;
end;
procedure SetAcquireFrame(var grec: tgrec; const fLeft, fTop, fRight, fBottom: double);
var
ImageLayout: TW_IMAGELAYOUT;
begin
LogWrite('SetAcquireFrame');
fillchar(ImageLayout, sizeof(TW_IMAGELAYOUT), 0);
with ImageLayout.Frame do
begin
FloatToFIX32(fLeft, @Left);
FloatToFIX32(fTop, @Top);
FloatToFIX32(fRight, @Right);
FloatToFIX32(fBottom, @Bottom);
end;
IETW_DS(grec, DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET, @ImageLayout);
LogWrite(' SetAcquireFrame : end');
end;
// get a Fix32 data (one, range, enum, array) and convert to double data
// free and realloc vlist
function GetFix32asDouble(var grec: tgrec; dlist: TIEDoubleList; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalEnum: pTW_ENUMERATION;
pvalOneValue: pTW_ONEVALUE;
pvalArray: pTW_ARRAY;
pvalRange: pTW_RANGE;
pfix: pTW_FIX32;
q: integer;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
dlist.clear;
LogWrite('GetFix32asDouble');
case twCapability.ConType of
TWON_ENUMERATION:
begin
pvalEnum := GlobalLock(twCapability.hContainer);
dlist.Count := pvalEnum^.NumItems;
if (dlist.Count > 0) then
begin
pfix := @(pvalEnum^.ItemList[0]);
for q := 0 to dlist.Count - 1 do
begin
dlist[q] := pfix^.Whole + pfix^.Frac / 65536;
inc(pfix);
end;
dlist.CurrentValue := dlist[pvalEnum^.CurrentIndex];
end
else
result := false;
end;
TWON_ONEVALUE:
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
dlist.Count := 1;
pfix := @(pvalOneValue^.Item);
dlist[0] := pfix^.Whole + pfix^.Frac / 65536;
if ((cap = ICAP_XRESOLUTION) or (cap = ICAP_YRESOLUTION)) and (dlist[0] < 0) then
dlist[0] := 300; // workaround for some scanner that return invalid resolution values
dlist.CurrentValue := dlist[0];
end;
TWON_ARRAY:
begin
pvalArray := GlobalLock(twCapability.hContainer);
dlist.Count := pvalArray^.NumItems;
pfix := @(pvalArray^.ItemList[0]);
for q := 0 to dlist.Count - 1 do
begin
dlist[q] := pfix^.Whole + pfix^.Frac / 65536;
inc(pfix);
end;
end;
TWON_RANGE:
begin
pvalRange := GlobalLock(twCapability.hContainer);
pfix := @(pvalRange^.MinValue);
dlist.RangeMin := pfix^.Whole + pfix^.Frac / 65536;
pfix := @(pvalRange^.MaxValue);
dlist.RangeMax := pfix^.Whole + pfix^.Frac / 65536;
pfix := @(pvalRange^.StepSize);
dlist.RangeStep := pfix^.Whole + pfix^.Frac / 65536;
pfix := @(pvalRange^.CurrentValue);
dlist.CurrentValue := pfix^.Whole + pfix^.Frac / 65536;
end;
else
result := false;
end;
GlobalUnlock(twCapability.hContainer);
GlobalFree(twCapability.hContainer);
if result then
LogWrite(' GetFix32asDouble : ok')
else
LogWrite(' GetFix32asDouble : FAILED!');
end;
function GetOneFIX32asDouble(var grec: tgrec; var Value: double; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pfix: pTW_FIX32;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('GetOnFIX32asDouble');
if twCapability.ConType = TWON_ONEVALUE then
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
pfix := @(pvalOneValue^.Item);
Value := pfix^.Whole + pfix^.Frac / 65536;
GlobalUnlock(twCapability.hContainer);
end
else
result := false;
GlobalFree(twCapability.hContainer);
if result then
LogWrite(' GetOneFIX32asDouble : ok')
else
LogWrite(' GetOneFIX32asDouble : FAILED!');
end;
// get a UINT16 data (one, range, enum, array) and convert to integer data
// free and realloc vlist
function GetUINT16asInteger(var grec: tgrec; ilist: TIEIntegerList; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalEnum: pTW_ENUMERATION;
pvalOneValue: pTW_ONEVALUE;
pvalArray: pTW_ARRAY;
pvalRange: pTW_RANGE;
v16: pTW_UINT16;
q: integer;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
ilist.Clear;
LogWrite('GetUINT16asInteger');
case twCapability.ConType of
TWON_ENUMERATION:
begin
pvalEnum := GlobalLock(twCapability.hContainer);
ilist.Count := pvalEnum^.NumItems;
if pvalEnum^.NumItems > 0 then // 3.0.3
begin
v16 := @(pvalEnum^.ItemList[0]);
for q := 0 to ilist.Count - 1 do
begin
ilist[q] := v16^;
inc(v16);
end;
ilist.CurrentValue := ilist[pvalEnum^.CurrentIndex];
end;
end;
TWON_ONEVALUE:
begin
pvalOneValue := GlobalLock(twCapability.hContainer);
ilist.Count := 1;
v16 := @(pvalOneValue^.Item);
ilist[0] := v16^;
ilist.CurrentValue := ilist[0];
end;
TWON_ARRAY:
begin
pvalArray := GlobalLock(twCapability.hContainer);
ilist.Count := pvalArray^.NumItems;
v16 := @(pvalArray^.ItemList[0]);
for q := 0 to ilist.Count - 1 do
begin
ilist[q] := v16^;
inc(v16);
end;
end;
TWON_RANGE:
begin
pvalRange := GlobalLock(twCapability.hContainer);
v16 := @(pvalRange^.MinValue);
ilist.RangeMin := v16^;
v16 := @(pvalRange^.MaxValue);
ilist.RangeMax := v16^;
v16 := @(pvalRange^.StepSize);
ilist.RangeStep := v16^;
v16 := @(pvalRange^.CurrentValue);
ilist.CurrentValue := v16^;
end;
else
result := false;
end;
GlobalUnlock(twCapability.hContainer);
GlobalFree(twCapability.hContainer);
if result then
LogWrite(' GetUINT16asInteger : ok')
else
LogWrite(' GetUINT16asInteger : FAILED!');
end;
// Supported only TW_ENUMERATION (allowed values and curr.) and TW_ONEVALUE (current value)
function SetIntegerAsUINT16Capability(var grec: tgrec; ilist: TIEIntegerList; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalEnum: pTW_ENUMERATION;
pvalOneValue: pTW_ONEVALUE;
v16: pTW_UINT16;
q: integer;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetIntegerAsUINT16Capability');
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
if ielItems in ilist.Changed then
begin
// write TW_ENUMERATION (allowed values and current value)
twCapability.ConType := TWON_ENUMERATION;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ENUMERATION) + sizeof(TW_UINT16) * ilist.Count);
try
pvalEnum := GlobalLock(twCapability.hContainer);
pvalEnum^.ItemType := TWTY_UINT16;
pvalEnum^.NumItems := ilist.Count;
pvalEnum^.CurrentIndex := ilist.IndexOf(ilist.CurrentValue);
v16 := @(pvalEnum^.ItemList[0]);
for q := 0 to ilist.Count - 1 do
begin
v16^ := ilist[q];
inc(v16);
end;
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
end;
if ielCurrentValue in ilist.Changed then
begin
// write TW_ONEVALUE (current value only)
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_UINT16;
pvalOneValue^.Item := ilist.CurrentValue;
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
end;
if result then
LogWrite(' SetIntegerAsUINT16Capability : ok')
else
LogWrite(' SetIntegerAsUINT16Capability : FAILED!');
end;
// Supported only TW_ENUMERATION (allowed values and curr.), TW_ONEVALUE (current value)
// TW_RANGE (allowed values and curr.)
function SetDoubleAsFIX32Capability(var grec: tgrec; dlist: TIEDoubleList; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalEnum: pTW_ENUMERATION;
pvalOneValue: pTW_ONEVALUE;
pvalRange: pTW_RANGE;
pfix: pTW_FIX32;
q: integer;
begin
result := true;
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetDoubleAsFIX32Capability');
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
if ielItems in dlist.Changed then
begin
// write TW_ENUMERATION (allowed values and current value)
twCapability.ConType := TWON_ENUMERATION;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ENUMERATION) + sizeof(TW_FIX32) * dlist.Count);
try
pvalEnum := GlobalLock(twCapability.hContainer);
pvalEnum^.ItemType := TWTY_FIX32;
pvalEnum^.NumItems := dlist.Count;
pvalEnum^.CurrentIndex := dlist.IndexOf(dlist.CurrentValue);
pfix := @(pvalEnum^.ItemList[0]);
for q := 0 to dlist.Count - 1 do
begin
FloatToFIX32(dlist[q], pfix);
inc(pfix);
end;
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
end;
if ielCurrentValue in dlist.Changed then
begin
// write TW_ONEVALUE (current value only)
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_FIX32;
FloatToFIX32(dlist.CurrentValue, @pvalOneValue^.Item);
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
end;
if ielRange in dlist.Changed then
begin
// write TW_RANGE (allowed values and current)
twCapability.ConType := TWON_RANGE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_RANGE));
try
pvalRange := GlobalLock(twCapability.hContainer);
pvalRange^.ItemType := TWTY_FIX32;
FloatToFIX32(dlist.CurrentValue, @pvalRange^.CurrentValue);
FloatToFIX32(dlist.RangeMin, @pvalRange^.MinValue);
FloatToFIX32(dlist.RangeMax, @pvalRange^.MaxValue);
FloatToFIX32(dlist.RangeStep, @pvalRange^.StepSize);
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
end;
if result then
LogWrite(' SetDoubleAsFIX32Capability : ok')
else
LogWrite(' SetDoubleAsFIX32Capability : FAILED!');
end;
// Supported TW_ONEVALUE (current value)
function SetOneDoubleAsFIX32Capability(var grec: tgrec; value: double; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
begin
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetOneDoubleAsFIX32Capability');
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
// write TW_ONEVALUE (current value only)
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_FIX32;
FloatToFIX32(value, @pvalOneValue^.Item);
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
if result then
LogWrite(' SetOneDoubleAsFIX32Capability : ok')
else
LogWrite(' SetOneDoubleAsFIX32Capability : FAILED!');
end;
// Supported TW_ONEVALUE (current value)
function SetOneUINT16Capability(var grec: tgrec; value: word; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pv16: pTW_UINT16;
begin
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetOneUINT16Capability');
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
// write TW_ONEVALUE (current value only)
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_UINT16;
pv16 := @(pvalOneValue^.Item);
pv16^ := value;
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
if result then
LogWrite(' SetOneUINT16Capability : ok')
else
LogWrite(' SetOneUINT16Capability : FAILED!');
end;
// Supported TW_ONEVALUE (current value)
function SetOneINT16Capability(var grec: tgrec; value: smallint; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pv16: pTW_INT16;
begin
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetOneINT16Capability');
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
// write TW_ONEVALUE (current value only)
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_INT16;
pv16 := @(pvalOneValue^.Item);
pv16^ := value;
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
if result then
LogWrite(' SetOneINT16Capability : ok')
else
LogWrite(' SetOneINT16Capability : FAILED!');
end;
function SetOneINT32Capability(var grec: tgrec; value: integer; cap: TW_UINT16): boolean;
var
twCapability: TW_CAPABILITY;
pvalOneValue: pTW_ONEVALUE;
pv32: pTW_INT32;
begin
if not GetCapability(grec, twCapability, cap) then
begin
result := false;
exit;
end;
LogWrite('SetOneINT32Capability');
GlobalFree(twCapability.hContainer);
twCapability.Cap := cap;
// write TW_ONEVALUE (current value only)
twCapability.ConType := TWON_ONEVALUE;
twCapability.hContainer := GlobalAlloc(GHND, sizeof(TW_ONEVALUE));
try
pvalOneValue := GlobalLock(twCapability.hContainer);
pvalOneValue^.ItemType := TWTY_INT32;
pv32 := @(pvalOneValue^.Item);
pv32^ := value;
GlobalUnLock(twCapability.hContainer);
IETW_DS(grec, DG_CONTROL, DAT_CAPABILITY, MSG_SET, @twCapability);
result := grec.rc = TWRC_SUCCESS;
finally
GlobalFree(twCapability.hContainer);
end;
if result then
LogWrite(' SetOneUINT16Capability : ok')
else
LogWrite(' SetOneUINT16Capability : FAILED!');
end;
// Need source loaded
function IETW_SetCapabilities(var grec: tgrec): boolean;
var
Units: TIEIntegerList;
xbuf: boolean;
xfer: TIEIntegerList;
chunk: TIEIntegerList;
itmp: TIEIntegerList;
begin
LogWrite('IETW_SetCapabilities');
if not grec.TWParams.CompatibilityMode then
begin
// 3.0.0: ICAP_PIXELTYPE and ICAP_BITDEPTH position
// ICAP_PIXELTYPE
// note: ImageEn buffer xfer supports BW(1bit), GRAYSCALE (8bit), RGB
if grec.TWParams.PixelType.CurrentValue > 2 then
grec.TWParams.PixelType.CurrentValue := 2; // force to RGB when type is PALETTE...CIEXYZ
LogWrite(' IETW_SetCapabilities : ICAP_PIXELTYPE');
xbuf := SetIntegerAsUINT16Capability(grec, grec.TWParams.PixelType, ICAP_PIXELTYPE);
// ICAP_BITDEPTH
if grec.TWParams.BitDepth.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_BITDEPTH');
SetIntegerAsUINT16Capability(grec, grec.TWParams.BitDepth, ICAP_BITDEPTH);
end;
// set ICAPS_UNITS first
LogWrite(' IETW_SetCapabilities : ICAP_UNITS');
Units := TIEIntegerList.Create;
try
if GetUINT16asInteger(grec, Units, ICAP_UNITS) and (Units.CurrentValue <> 0) then
begin
Units.CurrentValue := 0;
SetIntegerAsUINT16Capability(grec, Units, ICAP_UNITS);
end;
finally
FreeAndNil(Units);
end;
// ICAP_AUTOBRIGHT
if grec.TWParams.AutoBright then
begin
LogWrite(' IETW_SetCapabilities : ICAP_AUTOBRIGHT');
SetOneBoolCapability(grec, grec.TWParams.AutoBright, ICAP_AUTOBRIGHT);
end;
// ICAP_BRIGHTNESS
if grec.TWParams.Brightness.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_BRIGHTNESS');
SetDoubleAsFIX32Capability(grec, grec.TWParams.Brightness, ICAP_BRIGHTNESS);
end;
// ICAP_UNDEFINEDIMAGESIZE
if grec.TWParams.UndefinedImageSize then
begin
LogWrite(' IETW_SetCapabilities : ICAP_UNDEFINEDIMAGESIZE');
SetOneBoolCapability(grec, true, ICAP_UNDEFINEDIMAGESIZE);
end;
// ICAP_CONTRAST
if grec.TWParams.Contrast.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_CONTRAST');
SetDoubleAsFIX32Capability(grec, grec.TWParams.Contrast, ICAP_CONTRAST);
end;
// ICAP_FILTER
if grec.TWParams.Filter<>ietwUndefined then
begin
LogWrite(' IETW_SetCapabilities : ICAP_FILTER');
SetOneUINT16Capability(grec, integer(grec.TWParams.Filter)-1, ICAP_FILTER);
end;
// ICAP_THRESHOLD
if grec.TWParams.Threshold.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_THRESHOLD');
SetDoubleAsFIX32Capability(grec, grec.TWParams.Threshold, ICAP_THRESHOLD);
end;
// ICAP_ROTATION
if grec.TWParams.Rotation.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_ROTATION');
SetDoubleAsFIX32Capability(grec, grec.TWParams.Rotation, ICAP_ROTATION);
end;
// ICAP_PIXELFLAVOR
LogWrite(' IETW_SetCapabilities : ICAP_PIXELFLAVOR');
SetOneUINT16Capability(grec, TWPF_CHOCOLATE, ICAP_PIXELFLAVOR);
itmp := TIEIntegerList.Create;
try
if GetUINT16asInteger(grec, itmp, ICAP_PIXELFLAVOR) then
grec.BWToInvert := itmp.CurrentValue = TWPF_VANILLA
else
grec.BWToInvert := false; // not supported capability, assume TWPF_CHOCOLATE
finally
FreeAndNil(itmp);
end;
// ICAP_COMPRESSION (2.3.1)
LogWrite(' IETW_SetCapabilities : ICAP_COMPRESSION');
SetOneUINT16Capability(grec, TWCP_NONE, ICAP_COMPRESSION);
// ICAP_XRESOLUTION
if grec.TWParams.XResolution.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_XRESOLUTION');
SetDoubleAsFIX32Capability(grec, grec.TWParams.XResolution, ICAP_XRESOLUTION);
end;
// ICAP_YRESOLUTION
if grec.TWParams.YResolution.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_YRESOLUTION');
SetDoubleAsFIX32Capability(grec, grec.TWParams.YResolution, ICAP_YRESOLUTION);
end;
// ICAP_XSCALING
if grec.TWParams.XScaling.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_XSCALING');
SetDoubleAsFIX32Capability(grec, grec.TWParams.XScaling, ICAP_XSCALING);
end;
// ICAP_YSCALING
if grec.TWParams.YScaling.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_YSCALING');
SetDoubleAsFIX32Capability(grec, grec.TWParams.YScaling, ICAP_YSCALING);
end;
// set Chunky mode
chunk := TIEIntegerList.Create;
try
GetUINT16asInteger(grec, chunk, ICAP_PLANARCHUNKY);
if chunk.CurrentValue <> TWPC_CHUNKY then
begin
if xbuf and (grec.TWParams.PixelType.CurrentValue = 2) then
begin
LogWrite(' IETW_SetCapabilities : TWPC_CHUNKY - ICAP_PLANARCHUNKY');
xbuf := SetOneUINT16Capability(grec, TWPC_CHUNKY, ICAP_PLANARCHUNKY);
end;
end;
finally
FreeAndNil(chunk);
end;
// set "memory mode transfer"
if (grec.TransferMode = tmBuffered) and xbuf then
begin
xfer := TIEIntegerList.Create;
try
GetUINT16asInteger(grec, xfer, ICAP_XFERMECH);
if xfer.IndexOf(TWSX_MEMORY) < 0 then
grec.TransferMode := tmNative // do not support memory transfer (buffered transfer)
else
begin
LogWrite(' IETW_SetCapabilities : TWSX_MEMORY - ICAP_XFERMECH');
if not SetOneUINT16Capability(grec, TWSX_MEMORY, ICAP_XFERMECH) then
grec.TransferMode := tmNative
else
begin
xfer.Clear;
GetUINT16asInteger(grec, xfer, ICAP_XFERMECH);
if xfer.CurrentValue <> TWSX_MEMORY then
grec.TransferMode := tmNative;
end;
end;
finally
FreeAndNil(xfer);
end;
end
else
if grec.TransferMode <> tmFile then
grec.TransferMode := tmNative;
// CAP_FEEDERENABLED
LogWrite(' IETW_SetCapabilities : CAP_FEEDERENABLED');
SetOneBoolCapability(grec, grec.TWParams.FeederEnabled, CAP_FEEDERENABLED);
// CAP_AUTOFEED
if grec.TWParams.AutoFeed then
begin
LogWrite(' IETW_SetCapabilities : CAP_AUTOFEED');
SetOneBoolCapability(grec, grec.TWParams.AutoFeed, CAP_AUTOFEED);
end;
// ICAP_AUTOMATICDESKEW
if grec.TWParams.AutoDeskew then
begin
LogWrite(' IETW_SetCapabilities : ICAP_AUTOMATICDESKEW');
SetOneBoolCapability(grec, grec.TWParams.AutoDeskew, ICAP_AUTOMATICDESKEW);
end;
// ICAP_AUTOMATICBORDERDETECTION
if grec.TWParams.AutoBorderDetection then
begin
LogWrite(' IETW_SetCapabilities : ICAP_AUTOMATICBORDERDETECTION');
SetOneBoolCapability(grec, grec.TWParams.AutoBorderDetection, ICAP_AUTOMATICBORDERDETECTION);
end;
// ICAP_AUTOMATICROTATE
if grec.TWParams.AutoRotate then
begin
LogWrite(' IETW_SetCapabilities : ICAP_AUTOMATICROTATE');
SetOneBoolCapability(grec, grec.TWParams.AutoRotate, ICAP_AUTOMATICROTATE);
end;
// ICAP_AUTODISCARDBLANKPAGES
if grec.TWParams.AutoDiscardBlankPages<>-2 then
begin
LogWrite(' IETW_SetCapabilities : ICAP_AUTODISCARDBLANKPAGES');
SetOneINT32Capability(grec, grec.TWParams.AutoDiscardBlankPages, ICAP_AUTODISCARDBLANKPAGES);
end;
// ICAP_HIGHLIGHT
if grec.TWParams.Highlight<>-1 then
begin
LogWrite(' IETW_SetCapabilities : ICAP_HIGHLIGHT');
SetOneDoubleAsFIX32Capability(grec, grec.TWParams.Highlight, ICAP_HIGHLIGHT);
end;
// ICAP_SHADOW
if grec.TWParams.Shadow<>-1 then
begin
LogWrite(' IETW_SetCapabilities : ICAP_SHADOW');
SetOneDoubleAsFIX32Capability(grec, grec.TWParams.Shadow, ICAP_SHADOW);
end;
// CAP_AUTOSCAN
LogWrite(' IETW_SetCapabilities : CAP_AUTOSCAN');
SetOneBoolCapability(grec, grec.TWParams.AutoScan, CAP_AUTOSCAN);
// CAP_XFERCOUNT
// -2 = don't care (scanner default), -1 = multiple images, >1 = one or more images
if grec.TWParams.AcceptedImages<>-2 then
begin
LogWrite(' IETW_SetCapabilities : CAP_XFERCOUNT');
SetOneINT16Capability(grec, grec.TWParams.AcceptedImages, CAP_XFERCOUNT);
end;
// before 2.2.3 we first call ICAP_ORIENTATION then ICAP_SUPPORTEDSIZE
// ICAP_SUPPORTEDSIZES
if grec.TWParams.StandardSize.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_SUPPORTEDSIZES');
SetIntegerAsUINT16Capability(grec, grec.TWParams.StandardSize, ICAP_SUPPORTEDSIZES);
end;
// ICAP_ORIENTATION
if grec.TWParams.Orientation.Changed <> [] then
begin
LogWrite(' IETW_SetCapabilities : ICAP_ORIENTATION');
SetIntegerAsUINT16Capability(grec, grec.TWParams.Orientation, ICAP_ORIENTATION);
end;
// CAP_INDICATORS
LogWrite(' IETW_SetCapabilities : CAP_INDICATORS');
SetOneBoolCapability(grec, grec.TWParams.ProgressIndicators, CAP_INDICATORS);
// CAP_DUPLEXENABLED
if grec.TWParams.DuplexSupported then
begin
LogWrite(' IETW_SetCapabilities : CAP_DUPLEXENABLED');
SetOneBoolCapability(grec, grec.TWParams.DuplexEnabled, CAP_DUPLEXENABLED);
end;
// SETACQUIREFRAME
if grec.TWParams.AcquireFrameEnabled then
with grec.TWParams do
begin
LogWrite(' IETW_SetCapabilities : SETACQUIREFRAME');
SetAcquireFrame(grec, AcquireFrameLeft, AcquireFrameTop, AcquireFrameRight, AcquireFrameBottom);
end;
end
else
begin
// compatibility mode
grec.TransferMode := tmFile;
end;
result := true;
LogWrite(' IETW_SetCapabilities : end');
end;
// Bitmap is nil for multipage acquisition
function IETW_Acquire(Bitmap: TIEBitmap; multi: boolean; MultiCallBack: TIEMultiCallBack; Params: TIETwainParams; IOParams: TIOParams; var Progress: TProgressRec; TwainShared: PIETwainShared; callwnd: HWND; DoNativePixelFormat: boolean): boolean;
var
grec: tgrec;
wnd: HWND;
begin
if not Params.CapabilitiesValid then
Params.GetFromScanner;
result := false;
if IEGlobalSettings().IsInsideTwain then
exit;
IEGlobalSettings().IsInsideTwain := true;
try
Init_grec(grec);
grec.NativePixelFormat := DoNativePixelFormat;
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
grec.modal := true;
with grec do
begin
transferdone := false;
closedsok := false;
uionly := Params.ShowSettingsOnly;
gmulti := multi;
TWParams := Params;
end;
LogWrite('IETW_Acquire');
grec.IOParams := IOParams;
grec.fBitmap := Bitmap;
if Params.CompatibilityMode then
Params.FileTransfer := true;
if Params.FileTransfer then
grec.TransferMode := tmFile
else
if Params.BufferedTransfer then
grec.TransferMode := tmBuffered
else
grec.TransferMode := tmNative;
grec.MultiCallBack := MultiCallBack;
grec.Progress := @Progress;
Set_AppId(grec);
ClearError(grec); // clear error detail
wnd := CreateProxyWindow(grec);
grec.proxywnd := wnd;
if (not IETW_LoadSourceManager(grec)) then
begin
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_OpenSourceManager(grec, wnd)) then
begin
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_OpenSource(grec)) then
begin
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_SetCapabilities(grec)) then
begin
IETW_CloseSource(grec);
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_EnableSource(grec, wnd)) then
begin
IETW_CloseSource(grec);
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit
end;
EnableWindow(wnd, FALSE);
// source is enabled, wait for transfer or source closed
try
IETW_ModalEventLoop(grec);
finally
EnableWindow(wnd, TRUE);
end;
// shut everything down in the right sequence
// these routines do nothing if the corresponding 'open' failed
IETW_DisableSource(grec);
IETW_CloseSource(grec);
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
// invert black/white image if necessary
if assigned(Bitmap) and (Bitmap.PixelFormat = ie1g) and grec.BWToInvert then
_Negative1BitEx(Bitmap);
//
result := grec.transferdone or (grec.closedsok and grec.uionly);
LogWrite(' IETW_Acquire : end');
finally
if grec.fWindowList <> nil then
EnableTaskWindows(grec.fWindowList);
windows.SetActiveWindow(grec.actwnd);
IEGlobalSettings().IsInsideTwain := false;
end;
end;
function IETW_IsCapabilitySupported(Params: TIETwainParams; TwainShared: PIETwainShared; callwnd: HWND; cap: word): boolean;
var
grec: tgrec;
wnd: HWND;
twCapability: TW_CAPABILITY;
begin
result := false;
if IEGlobalSettings().IsInsideTwain then
exit;
IEGlobalSettings().IsInsideTwain := true;
try
Init_grec(grec);
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
grec.TWParams := Params;
ClearError(grec); // clear error detail
wnd := CreateProxyWindow(grec);
grec.proxywnd := wnd;
if (not IETW_LoadSourceManager(grec)) then
begin
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_OpenSourceManager(grec, wnd)) then
begin
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_OpenSource(grec)) then
begin
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
result := GetCapability(grec, twCapability, cap);
IETW_CloseSource(grec);
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
finally
windows.SetActiveWindow(grec.actwnd);
IEGlobalSettings().IsInsideTwain := false;
end;
end;
// if setcap is True then set capabilities and doesn't change the "Changed" field of the lists
// return false if fails
function IETW_GetCapabilities(Params: TIETwainParams; var Capabilities: TIETWSourceCaps; setcap: boolean; TwainShared: PIETwainShared; callwnd: HWND): boolean;
var
grec: tgrec;
wnd: HWND;
Units: TIEIntegerList;
temp_i: integer;
fXResolutionChanged: TIEListChanges;
fYResolutionChanged: TIEListChanges;
fXScalingChanged: TIEListChanges;
fYScalingChanged: TIEListChanges;
fPixelTypeChanged: TIEListChanges;
fBitDepthChanged: TIEListChanges;
fOrientationChanged: TIEListChanges;
fContrastChanged: TIEListChanges;
fBrightnessChanged: TIEListChanges;
fStandardSizeChanged: TIEListChanges;
fThresholdChanged: TIEListChanges;
fRotationChanged: TIEListChanges;
begin
result := false;
if IEGlobalSettings().IsInsideTwain then
exit;
IEGlobalSettings().IsInsideTwain := true;
try
Init_grec(grec);
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
grec.TWParams := Params;
if Params.CompatibilityMode then
Params.FileTransfer := true;
if Params.FileTransfer then
grec.TransferMode := tmFile
else
if Params.BufferedTransfer then
grec.TransferMode := tmBuffered
else
grec.TransferMode := tmNative;
ClearError(grec); // clear error detail
wnd := CreateProxyWindow(grec);
grec.proxywnd := wnd;
if (not IETW_LoadSourceManager(grec)) then
begin
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_OpenSourceManager(grec, wnd)) then
begin
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if (not IETW_OpenSource(grec)) then
begin
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
if setcap then
IETW_SetCapabilities(grec);
with grec, Capabilities do
begin
fXResolutionChanged := fXResolution.Changed;
fYResolutionChanged := fYResolution.Changed;
fXScalingChanged := fXScaling.Changed;
fYScalingChanged := fYScaling.Changed;
fPixelTypeChanged := fPixelType.Changed;
fBitDepthChanged := fBitDepth.Changed;
fOrientationChanged := fOrientation.Changed;
fContrastChanged := fContrast.Changed;
fBrightnessChanged := fBrightness.Changed;
fStandardSizeChanged := fStandardSize.Changed;
fThresholdChanged := fThreshold.Changed;
fRotationChanged := fRotation.Changed;
if not Params.CompatibilityMode then
begin
// set ICAPS_UNITS first
Units := TIEIntegerList.Create;
try
if GetUINT16asInteger(grec, Units, ICAP_UNITS) and (Units.CurrentValue <> 0) then
begin
Units.CurrentValue := 0;
SetIntegerAsUINT16Capability(grec, Units, ICAP_UNITS);
end;
finally
FreeAndNil(Units);
end;
end;
// ICAP_XRESOLUTION
if not GetFix32asDouble(grec, fXResolution, ICAP_XRESOLUTION) then
fXResolution.Clear;
// ICAP_YRESOLUTION
if not GetFix32asDouble(grec, fYResolution, ICAP_YRESOLUTION) then
fYResolution.Clear;
if not Params.CompatibilityMode then
begin
// ICAP_XSCALING
if not GetFix32asDouble(grec, fXScaling, ICAP_XSCALING) then
begin
fXScaling.Clear;
fXScaling.Add(1);
end;
// ICAP_YSCALING
if not GetFix32asDouble(grec, fYScaling, ICAP_YSCALING) then
begin
fYScaling.Clear;
fYScaling.Add(1);
end;
// ICAP_CONTRAST
if not GetFix32asDouble(grec, fContrast, ICAP_CONTRAST) then
fContrast.Clear;
// ICAP_BRIGHTNESS
if not GetFix32asDouble(grec, fBrightness, ICAP_BRIGHTNESS) then
fBrightness.Clear;
// ICAP_THRESHOLD
if not GetFix32asDouble(grec, fThreshold, ICAP_THRESHOLD) then
fThreshold.Clear;
// ICAP_ROTATION
if not GetFix32asDouble(grec, fRotation, ICAP_ROTATION) then
fRotation.Clear;
// ICAP_PIXELTYPE
if not GetUINT16asinteger(grec, fPixelType, ICAP_PIXELTYPE) then
fPixelType.Clear;
// ICAP_BITDEPTH
if not GetUINT16asinteger(grec, fBitDepth, ICAP_BITDEPTH) then
fBitDepth.Clear;
// ICAP_GAMMA
if not GetOneFIX32asDouble(grec, fGamma, ICAP_GAMMA) then
fGamma := 2.2;
// ICAP_PHYSICALHEIGHT
if not GetOneFIX32asDouble(grec, fPhysicalHeight, ICAP_PHYSICALHEIGHT) then
fPhysicalHeight := 0;
// ICAP_PHYSICALWIDTH
if not GetOneFIX32asDouble(grec, fPhysicalWidth, ICAP_PHYSICALWIDTH) then
fPhysicalWidth := 0;
// CAP_FEEDERENABLED
if not GetOneBOOL(grec, fFeederEnabled, CAP_FEEDERENABLED) then
fFeederEnabled := false;
// CAP_AUTOFEED
if not GetOneBOOL(grec, fAutoFeed, CAP_AUTOFEED) then
fAutoFeed := false;
// ICAP_AUTOMATICDESKEW
if not GetOneBOOL(grec, fAutoDeskew, ICAP_AUTOMATICDESKEW) then
fAutoDeskew := false;
// ICAP_AUTOMATICBORDERDETECTION
if not GetOneBOOL(grec, fAutoBorderDetection, ICAP_AUTOMATICBORDERDETECTION) then
fAutoBorderDetection := false;
// ICAP_AUTOBRIGHT
if not GetOneBOOL(grec, fAutoBright, ICAP_AUTOBRIGHT) then
fAutoBright := false;
// ICAP_AUTOMATICROTATE
if not GetOneBOOL(grec, fAutoRotate, ICAP_AUTOMATICROTATE) then
fAutoRotate := false;
// ICAP_AUTODISCARDBLANKPAGES
if not GetOneINT32(grec, fAutoDiscardBlankPages, ICAP_AUTODISCARDBLANKPAGES) then
fAutoDiscardBlankPages := -2;
// ICAP_FILTER
if not GetOneUINT16(grec, temp_i, ICAP_FILTER) then
fFilter := ietwUndefined
else
fFilter := TIETWFilter(temp_i+1);
// ICAP_HIGHLIGHT
if not GetOneFIX32asDouble(grec, fHighlight, ICAP_HIGHLIGHT) then
fHighlight := -1;
// ICAP_SHADOW
if not GetOneFIX32asDouble(grec, fShadow, ICAP_SHADOW) then
fShadow := -1;
// CAP_AUTOSCAN
if not GetOneBOOL(grec, fAutoScan, CAP_AUTOSCAN) then
fAutoScan := false;
// CAP_DEVICEONLINE
if not GetOneBOOL(grec, fDeviceOnline, CAP_DEVICEONLINE) then
fDeviceOnline := false;
// CAP_XFERCOUNT
if not GetOneINT16(grec, temp_i, CAP_XFERCOUNT) then
fAcceptedImages := -2
else
fAcceptedImages := temp_i;
// CAP_FEEDERLOADED
if not GetOneBOOL(grec, fFeederLoaded, CAP_FEEDERLOADED) then
fFeederLoaded := false;
// CAP_PAPERDETECTABLE
if not GetOneBOOL(grec, fPaperDetectable, CAP_PAPERDETECTABLE) then
fPaperDetectable := false;
// CAP_DUPLEXENABLED
if not GetOneBOOL(grec, fDuplexEnabled, CAP_DUPLEXENABLED) then
fDuplexEnabled := false;
// CAP_DUPLEX
fDuplexSupported := GetOneUINT16(grec, temp_i, CAP_DUPLEX) and (temp_i<>0); // 3.0.3
// ICAP_ORIENTATION
if not GetUINT16asInteger(grec, fOrientation, ICAP_ORIENTATION) then
begin
fOrientation.Clear;
fOrientation.Add(TWOR_PORTRAIT);
end;
// ICAP_SUPPORTEDSIZES (renamed as StandardSize)
if not GetUINT16asInteger(grec, fStandardSize, ICAP_SUPPORTEDSIZES) then
fStandardSize.Clear;
// CAP_INDICATORS
if not GetOneBOOL(grec, fIndicators, CAP_INDICATORS) then
fIndicators := True;
// Acquire Frame
if fAcquireFrameEnabled then
GetAcquireFrame(grec, fAcquireFrame);
// clear Changed property of lists
if not setcap then
begin
fXResolution.Changed := [];
fYResolution.Changed := [];
fXScaling.Changed := [];
fYScaling.Changed := [];
fPixelType.Changed := [];
fBitDepth.Changed := [];
fOrientation.Changed := [];
fContrast.Changed := [];
fBrightness.Changed := [];
fStandardSize.Changed := [];
fThreshold.Changed := [];
fRotation.Changed := [];
end
else
begin
fXResolution.Changed := fXResolutionChanged;
fYResolution.Changed := fYResolutionChanged;
fXScaling.Changed := fXScalingChanged;
fYScaling.Changed := fYScalingChanged;
fPixelType.Changed := fPixelTypeChanged;
fBitDepth.Changed := fBitDepthChanged;
fOrientation.Changed := fOrientationCHanged;
fContrast.Changed := fContrastChanged;
fBrightness.Changed := fBrightnessChanged;
fStandardSize.Changed := fStandardSizeChanged;
fThreshold.Changed := fThresholdChanged;
fRotation.Changed := fRotationChanged;
end;
end;
end;
IETW_CloseSource(grec);
IETW_CloseSourceManager(grec, wnd);
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
result := true;
finally
windows.SetActiveWindow(grec.actwnd);
IEGlobalSettings().IsInsideTwain := false;
end;
end;
// returns ProductName of default source
function IETW_GetDefaultSource(TwainShared: PIETwainShared; callwnd: HWND): AnsiString;
var
NewSourceId: TW_IDENTITY;
grec: tgrec;
wnd: HWND;
begin
result := '';
if IEGlobalSettings().IsInsideTwain then
exit;
IEGlobalSettings().IsInsideTwain := true;
Init_grec(grec);
try
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
wnd := CreateProxyWindow(grec);
grec.proxywnd := wnd;
if IETW_LoadSourceManager(grec) then
begin
if IETW_OpenSourceManager(grec, wnd) then
begin
fillmemory(@NewSourceId, sizeof(NewSourceId), 0);
// Post the Select Source dialog
if IETW_Mgr(grec, DG_CONTROL, DAT_IDENTITY, MSG_GETDEFAULT, @NewSourceId) then
result := NewSourceId.ProductName;
IETW_CloseSourceManager(grec, wnd);
end
else
begin
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
exit;
end;
IETW_UnloadSourceManager(grec, IEGlobalSettings().ReleaseTwainResources);
end;
DestroyProxyWindow(wnd, grec, IEGlobalSettings().ReleaseTwainResources);
finally
windows.SetActiveWindow(grec.actwnd);
IEGlobalSettings().IsInsideTwain := false;
end;
end;
// unload sourcemanager
procedure IETW_FreeResources(TwainShared: PIETwainShared; callwnd: HWND);
var
grec: tgrec;
begin
Init_grec(grec);
grec.callwnd := callwnd;
grec.PTwainShared := TwainShared;
grec.hDSMLib := TwainShared.hDSMLib;
grec.DSM_Entry := TwainShared.DSM_Entry;
if grec.PTwainShared^.hproxy <> 0 then
DestroyProxyWindow(0, grec, true);
if grec.PTwainShared^.hDSMLib <> 0 then
IETW_UnloadSourceManager(grec, true);
end;
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
// New implementation
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
procedure _IETWAINAcquireClose(var grec: pointer); forward;
{$IFDEF Delphi6orNewer}
{$WARN SYMBOL_DEPRECATED OFF}
{$ENDIF}
constructor TIEProxyWin.Create(xgrec: pgrec);
begin
grec := xgrec;
handle := AllocateHWnd(WndProc);
end;
destructor TIEProxyWin.Destroy;
begin
_IETWAINAcquireClose(pointer(grec));
DeallocateHWnd(handle);
inherited;
end;
{$IFDEF Delphi6orNewer}
{$WARN SYMBOL_DEPRECATED ON}
{$ENDIF}
procedure TIEProxyWin.WndProc(var Message: TMessage);
var
msg: TMSG;
begin
msg.hwnd := handle;
msg.message := Message.Msg;
msg.wParam := Message.WParam;
msg.lParam := Message.LParam;
if not assigned(grec) then
LogWrite('TIEProxyWin.WndProc. Msg=' + IEIntToStr(msg.message) + ' grec=' + IEIntToStr(NativeInt(grec)) + ' grec no assigned!')
else
LogWrite('TIEProxyWin.WndProc. Msg=' + IEIntToStr(msg.message) + ' grec=' + IEIntToStr(NativeInt(grec)) + ' state=' + IEIntToStr(grec^.nstate));
if (not assigned(grec)) or (grec^.nState < 5) or (not IETW_MessageHook(grec^, @msg)) then
with Message do
Result := DefWindowProc(handle, Msg, wParam, lParam);
end;
function IETWAINAcquireOpen(CloseCallBack: TIETWCloseCallBack; MultiCallBack: TIEMultiCallBack; Params: TIETwainParams; TwainShared: PIETwainShared; IOParams: TIOParams; parent: TWinControl; DoNativePixelFormat: boolean): pointer;
var
grec: pgrec;
begin
new(grec);
Init_grec(grec^);
with grec^ do
begin
transferdone := false;
closedsok := false;
TWParams := Params;
NativePixelFormat := DoNativePixelFormat;
end;
grec.PTwainShared := TwainShared;
grec.modal := false;
grec.IOParams := IOParams;
if Params.FileTransfer then
grec.TransferMode := tmFile
else
if Params.BufferedTransfer then
grec.TransferMode := tmBuffered
else
grec.TransferMode := tmNative;
grec.MultiCallBack := MultiCallBack;
grec.Progress := nil;
grec.gmulti := true;
grec.fclosecallback := CloseCallBack;
Set_AppId(grec^);
ClearError(grec^); // clear error detail
// create proxy window
grec^.ProxyWin := TIEProxyWin.Create(grec);
try
if (not IETW_LoadSourceManager(grec^)) then
begin
FreeAndNil(grec.ProxyWin);
//dispose(grec); // already disposes by ProxyWin.free
result := nil;
exit;
end;
if (not IETW_OpenSourceManager(grec^, grec.ProxyWin.Handle)) then
begin
IETW_UnloadSourceManager(grec^, IEGlobalSettings().ReleaseTwainResources);
FreeAndNil(grec.ProxyWin);
dispose(grec);
result := nil;
exit;
end;
if (not IETW_OpenSource(grec^)) then
begin
IETW_CloseSourceManager(grec^, grec.ProxyWin.Handle);
IETW_UnloadSourceManager(grec^, IEGlobalSettings().ReleaseTwainResources);
FreeAndNil(grec.ProxyWin);
//dispose(grec); // already disposes by ProxyWin.free
result := nil;
exit;
end;
if (not IETW_SetCapabilities(grec^)) then
begin
IETW_CloseSource(grec^);
IETW_CloseSourceManager(grec^, grec.ProxyWin.Handle);
IETW_UnloadSourceManager(grec^, IEGlobalSettings().ReleaseTwainResources);
FreeAndNil(grec.ProxyWin);
//dispose(grec); // already disposes by ProxyWin.free
result := nil;
exit;
end;
if (not IETW_EnableSource(grec^, grec.ProxyWin.Handle)) then
begin
IETW_CloseSource(grec^);
IETW_CloseSourceManager(grec^, grec.ProxyWin.Handle);
IETW_UnloadSourceManager(grec^, IEGlobalSettings().ReleaseTwainResources);
FreeAndNil(grec.ProxyWin);
//dispose(grec); // already disposes by ProxyWin.free
result := nil;
exit
end;
result := grec;
LogWrite('IETWAINAcquireOpen : result= ' + IEIntToStr(integer(result)));
finally
//windows.SetActiveWindow(grec.actwnd);
end;
end;
// important: ProxyWin will be destroyed by parent!!!
// otherwise you can destroy it calling this function!
// called from external (then ProxyWin is not in destroying state)
procedure IETWAINAcquireClose(var grec: pointer);
begin
LogWrite('IETWAINAcquireClose : begin');
FreeAndNil(pgrec(grec)^.ProxyWin);
LogWrite('IETWAINAcquireClose : end');
end;
// called from TIEProxyWin (ProxyWin must be in destroying state)
procedure _IETWAINAcquireClose(var grec: pointer);
var
closecallback: TIETWCloseCallBack;
begin
LogWrite('_IETWAINAcquireClose : begin');
IETW_DisableSource(pgrec(grec)^);
IETW_CloseSource(pgrec(grec)^);
IETW_CloseSourceManager(pgrec(grec)^, pgrec(grec)^.hwndSM);
IETW_UnloadSourceManager(pgrec(grec)^, true);
closecallback := pgrec(grec)^.fclosecallback;
dispose(grec);
closecallback;
grec := nil;
LogWrite('_IETWAINAcquireClose : end');
end;
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////
{$ELSE} // {$ifdef IEINCLUDEIEXACQUIRE}
interface
implementation
{$ENDIF}
end.