📄 imscan.pas
字号:
// 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 (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 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
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;
if bHideUI then
fAborting := true;
break;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_FAILURE');
nState := 6;
if bHideUI then
fAborting := true;
// version 2.1.6-3
if assigned(Progress) then
Progress^.Aborting^:=true;
//
break;
end;
end;
// OnProgress
if assigned(Progress) then
with Progress^ do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * (imxfer.YOffset + imxfer.Rows)));
until false;
if not TWParams.UseMemoryHandle then
GlobalUnlock(hbuff);
GlobalFree(hbuff);
if DelayImageInfo then
begin
while buffers.Count > 0 do
begin
pimxfer := buffers[0];
freemem(pimxfer^.Memory.TheMem);
dispose(pimxfer);
buffers.delete(0);
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');
_CopyDIB2BitmapEx(hNative, fBitmap, nil, false);
GlobalFree(hNative); // 2.0.9
//
nState := 7;
transferdone := true;
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
if bHideUI then
fAborting := true;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_FAILURE');
nState := 6;
if bHideUI then
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.Create(nil);
io.AttachedIEBitmap := fBitmap;
io.LoadFromFileFormat(setupfilexfer.FileName, FindFileFormat(setupfilexfer.FileName, false));
FreeAndNil(io);
DeleteFile( setupfilexfer.FileName );
//
nState := 7;
transferdone := true;
end;
TWRC_CANCEL:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_CANCEL');
breakmodalloop := true;
nState := 7;
if bHideUI then
fAborting := true;
end;
TWRC_FAILURE:
begin
LogWrite(' IETW_XferReadyMulti : TWRC_FAILURE');
nState := 6;
if bHideUI then
fAborting := true;
end;
else
nState := 6;
end;
end;
end;
//
if (fBitmap.PixelFormat = ie1g) and grec.BWToInvert then
_Negative1BitEx(fBitmap);
MultiCallBack(fBitmap, TObject(IOParams));
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 := 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;
if IOParams.ColorMap <> nil then
begin
freemem(IOParams.ColorMap);
IOParams.fColorMap := nil;
IOParams.fColorMapCount := 0;
end;
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=$' + inttohex(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_NULL:
begin
// no message returned from DS
LogWrite(' IETW_MessageHook : MSG_NULL');
end;
end;
end;
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=$' + inttohex(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;
///////////////////////////////////////////////////////////////////////////////////////
procedure IETW_GetSourceList(SList: TList; TWainShared: PIETWainShared; callwnd: HWND);
var
SourceId: pTW_IDENTITY;
grec: tgrec;
wnd: HWND;
begin
try
SList.Clear;
Init_grec(grec);
grec.callwnd := callwnd;
grec.PTWainShared := TWainShared;
wnd := CreateProxyWindow(grec);
if (IETW_LoadSourceManager(grec)) then
begin
if (IETW_OpenSourceManager(grec, wnd)) then
begin
SourceId := AllocMem(sizeof(TW_IDENTITY));
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;
FreeMem(SourceId); // last not assigned
IETW_CloseSourceManager(grec, wnd);
end
else
begin
DestroyProxyWindow(wnd, grec, false);
exit;
end;
IETW_UnloadSourceManager(grec, false);
end
else
begin
DestroyProxyWindow(wnd, grec, false);
exit;
end;
DestroyProxyWindow(wnd, grec, false);
finally
windows.setactivewindow(grec.actwnd);
end;
end;
(*
procedure FloatToFIX32(const floater:double; fix32:pTW_FIX32);
var
value:integer;
begin
value:=trunc(floater*65536+0.5);
fix32^.Whole:=value shr 16;
fix32^.Frac:=value and $0000FFFF;
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
end;
end;
///////////////////////////////////////////////////////////////////////////////////////
procedure GetAcquireFrame(var grec: tgrec; var fAcquireFrame: TIEDRect);
var
ImageLayout: TW_IMAGELAYOU⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -