проверь на железе
| Код |
program ReadFields;
{$APPTYPE CONSOLE}
uses
System.SysUtils, Winapi.Windows;
type
TTopLevelWindow = record
Wnd: HWND;
hProcess: THandle;
end;
TFindWinControlCbRec = record
Wnd: HWND;
ClassName: String;
SeqIndex: Integer;
end;
TField = record
FieldName,
TypeName: String;
FieldOffset: Cardinal;
end;
const
oldvmtSelfPtr = -88;
oldvmtTypeInfo = -72;
oldvmtFieldTable = -68;
oldvmtClassName = -56;
oldvmtInstanceSize = -52;
function GetProcessHandleFromHwnd(Wnd: HWND): THandle; stdcall; external 'oleacc.dll';
function FindTopLevelWindow(const WndClass: String): TTopLevelWindow;
begin
Result.Wnd := FindWindow(PChar(WndClass), nil);
if Result.Wnd = 0
then raise Exception.Create('Top-level window not found');
Result.hProcess := GetProcessHandleFromHwnd(Result.Wnd);
if Result.hProcess = 0 then RaiseLastOsError;
end;
function FindWinControlCb(Wnd: HWND; var Rec: TFindWinControlCbRec): BOOL; stdcall;
var
ClassName: String;
Len: Integer;
begin
Result := True;
SetLength(ClassName, Length(Rec.ClassName) + 1);
Len := GetClassName(Wnd, @ClassName[1], Length(ClassName) + 1);
if Len = 0 then RaiseLastOsError;
SetLength(ClassName, Len);
if AnsiSameText(ClassName, Rec.ClassName)
then begin
Dec(Rec.SeqIndex);
if Rec.SeqIndex < 0
then begin
Rec.Wnd := Wnd;
Result := False
end;
end;
end;
function FindWinControl(const TopWnd: HWND; const WinControlClass: String;
SeqIndex: Integer): DWORD;
var
RM_GetObjectInstance: UINT;
PID: DWORD;
Rec: TFindWinControlCbRec;
begin
Rec.Wnd := 0;
Rec.ClassName := WinControlClass;
Rec.SeqIndex := SeqIndex;
EnumChildWindows(TopWnd, @FindWinControlCb, LPARAM(@Rec));
if Rec.Wnd = 0
then raise Exception.Create('Control not found');
if GetWindowThreadProcessId(Rec.Wnd, PID) = 0
then RaiseLastOsError;
RM_GetObjectInstance := RegisterWindowMessage('DelphiRM_GetObjectInstance');
Result := DWORD(SendMessage(Rec.Wnd, RM_GetObjectInstance, WPARAM(PID), 0));
end;
function ReadString(hProcess: THandle; Ptr: DWORD): String;
var
Str: ShortString;
BytesRead: SIZE_T;
begin
if not ReadProcessMemory(hProcess, Pointer(Ptr), @Str[0], SizeOf(Str[0]),
BytesRead)
then RaiseLastOsError;
Inc(Ptr, SizeOf(Str[0]));
if not ReadProcessMemory(hProcess, Pointer(Ptr), @Str[1], Length(Str),
BytesRead)
then RaiseLastOsError;
Result := String(Str)
end;
procedure EnumFields(hProcess: THandle; VMT: DWORD; Cb: TFunc<TField, Boolean>);
procedure ReadPPTypeInfo(pPtr: DWORD; var Fld: TField);
var
dw: DWORD;
BytesRead: SIZE_T;
tk: TTypeKind;
ElSize: Integer;
begin
if not ReadProcessMemory(hProcess, Pointer(pPtr), @dw, SizeOf(dw), BytesRead)
then RaiseLastOsError;
if not ReadProcessMemory(hProcess, Pointer(dw), @tk, SizeOf(tk), BytesRead)
then RaiseLastOsError;
Inc(dw, SizeOf(tk));
Fld.TypeName := ReadString(hProcess, dw);
if ((Fld.TypeName = '') or (Fld.TypeName[1] = ':')) and (tk = tkDynArray)
then begin
Inc(dw, 1 + Length(Fld.TypeName));
Fld.TypeName := 'array of ';
if not ReadProcessMemory(hProcess, Pointer(dw), @ElSize,
SizeOf(ElSize), BytesRead)
then RaiseLastOsError;
Inc(dw, SizeOf(Integer)); // elSize: Integer
if not ReadProcessMemory(hProcess, Pointer(dw), @pPtr, SizeOf(pPtr),
BytesRead)
then RaiseLastOsError;
if pPtr = 0
then Fld.TypeName := Format('%s<%d byte(s)>', [Fld.TypeName, ElSize])
else begin
if not ReadProcessMemory(hProcess, Pointer(pPtr), @dw, SizeOf(dw),
BytesRead)
then RaiseLastOsError;
Inc(dw, SizeOf(tk));
Fld.TypeName := Fld.TypeName + ReadString(hProcess, dw);
end;
end;
end;
var
dw, TypeInfo: DWORD;
BytesRead: SIZE_T;
Count: Word;
i: Integer;
Fld: TField;
begin
if not ReadProcessMemory(hProcess, PByte(VMT) + oldvmtFieldTable, @dw,
SizeOf(dw), BytesRead)
then RaiseLastOsError;
if not ReadProcessMemory(hProcess, Pointer(dw), @Count, SizeOf(Count), BytesRead)
then RaiseLastOsError;
if Count <> 0
then raise Exception.Create('Old-style TVmtFieldEntry is not supported');
Inc(dw, SizeOf(Count));
Inc(dw, SizeOf(DWORD)); // ClassTab: PVmtFieldClassTab
if not ReadProcessMemory(hProcess, Pointer(dw), @Count, SizeOf(Count), BytesRead)
then RaiseLastOsError;
Inc(dw, SizeOf(Count));
for i := 1 to Count do
begin
Inc(dw); // Flags: Byte;
if not ReadProcessMemory(hProcess, Pointer(dw), @TypeInfo, SizeOf(TypeInfo),
BytesRead)
then RaiseLastOsError;
ReadPPTypeInfo(TypeInfo, Fld);
Inc(dw, SizeOf(TypeInfo));
if not ReadProcessMemory(hProcess, Pointer(dw), @Fld.FieldOffset,
SizeOf(Fld.FieldOffset), BytesRead)
then RaiseLastOsError;
Inc(dw, SizeOf(Fld.FieldOffset));
Fld.FieldName := ReadString(hProcess, dw);
if not Cb(Fld) then Break;
Inc(dw, 1 + Length(Fld.FieldName));
if not ReadProcessMemory(hProcess, Pointer(dw), @Count, SizeOf(Count), BytesRead)
then RaiseLastOsError;
Inc(dw, Count); // TAttrData
end;
end;
procedure DumpFields(hProcess: THandle; VMT: DWORD);
begin
EnumFields(hProcess, VMT, function (Fld: TField): Boolean
begin
Result := True;
writeln(Fld.FieldName, ': ', Fld.TypeName, ' @ ', Fld.FieldOffset);
end);
end;
function FindFieldOffset(hProcess: THandle; VMT: DWORD;
const FldName: String): DWORD;
var
FldPtr: DWORD;
begin
FldPtr := 0;
EnumFields(hProcess, VMT, function (Fld: TField): Boolean
var
InstSize: DWORD;
BytesRead: SIZE_T;
begin
Result := not AnsiSameText(Fld.FieldName, FldName);
if not Result
then begin
FldPtr := Fld.FieldOffset;
if not ReadProcessMemory(hProcess, PByte(VMT) + oldvmtInstanceSize,
@InstSize, SizeOf(InstSize), BytesRead)
then RaiseLastOsError;
if Fld.FieldOffset > InstSize
then raise Exception.Create('Instance too small');
end;
end);
Result := FldPtr;
if Result = 0
then raise Exception.Create('Field not found')
end;
function GetVmtClassName(hProcess: THandle; VMT: DWORD): String;
var
dw: DWORD;
BytesRead: SIZE_T;
begin
if not ReadProcessMemory(hProcess, PByte(VMT) + oldvmtClassName, @dw,
SizeOf(dw), BytesRead)
then RaiseLastOsError;
Result := ReadString(hProcess, dw)
end;
function FindVmt(hProcess: THandle; Obj: DWORD): DWORD;
var
BytesRead: SIZE_T;
dw: DWORD;
tk: TTypeKind;
begin
if not ReadProcessMemory(hProcess, Pointer(Obj), @Result, SizeOf(Result),
BytesRead)
then RaiseLastOsError;
if not ReadProcessMemory(hProcess, PByte(Result) + oldvmtSelfPtr, @dw,
SizeOf(dw), BytesRead)
then RaiseLastOsError;
if dw <> Result
then raise Exception.Create('vmtSelfPtr not found');
if not ReadProcessMemory(hProcess, PByte(Result) + oldvmtTypeInfo, @dw,
SizeOf(dw), BytesRead)
then RaiseLastOsError;
if not ReadProcessMemory(hProcess, Pointer(dw), @tk, SizeOf(tk), BytesRead)
then RaiseLastOsError;
if tk <> tkClass
then raise Exception.Create('VMT is present but TTypeInfo.Kind <> tkClass');
Inc(dw, SizeOf(tk));
if not AnsiSameText(GetVmtClassName(hProcess, Result), ReadString(hProcess, dw))
then raise Exception.Create('ClassName mismatch')
end;
procedure DumpArrayOfDouble(hProcess: THandle; ArrFld: DWORD);
var
BytesRead: SIZE_T;
ArrPtr: DWORD;
Len, i: Integer;
Arr: array of Double;
begin
if not ReadProcessMemory(hProcess, Pointer(ArrFld), @ArrPtr,
SizeOf(ArrPtr), BytesRead)
then RaiseLastOsError;
if not ReadProcessMemory(hProcess, Pointer(ArrPtr - SizeOf(Len)), @Len,
SizeOf(Len), BytesRead)
then RaiseLastOsError;
SetLength(Arr, Len);
if not ReadProcessMemory(hProcess, Pointer(ArrPtr), @Arr[0],
SizeOf(Arr[0]) * Len, BytesRead)
then RaiseLastOsError;
for i := 0 to Len div 2 - 1 do
writeln(Arr[i * 2], ' ', Arr[i * 2 + 1]);
end;
function ReadBoolean(hProcess: THandle; Fld: DWORD): Boolean;
var
BytesRead: SIZE_T;
begin
if not ReadProcessMemory(hProcess, Pointer(Fld), @Result,
SizeOf(Result), BytesRead)
then RaiseLastOsError;
end;
procedure DumpDouble(hProcess: THandle; Fld: DWORD);
var
BytesRead: SIZE_T;
Dbl: Double;
begin
if not ReadProcessMemory(hProcess, Pointer(Fld), @Dbl,
SizeOf(Dbl), BytesRead)
then RaiseLastOsError;
writeln(Dbl)
end;
const
FlowDiagramClassName = 'TFlowDiagram';
AngularMetterClassName = 'TAngularMetter';
var
TopWnd: TTopLevelWindow;
Ctrl, Fld, VMT: DWORD;
begin
try
TopWnd := FindTopLevelWindow('TFormARMDStensdMain');
try
writeln(FlowDiagramClassName, ':');
Ctrl := FindWinControl(TopWnd.Wnd, FlowDiagramClassName, 0);
VMT := FindVmt(TopWnd.hProcess, Ctrl);
if not AnsiSameText(FlowDiagramClassName, GetVmtClassName(TopWnd.hProcess, VMT))
then raise Exception.Create('ClassName mismatch');
//DumpFields(TopWnd.hProcess, VMT);
Fld := Ctrl + FindFieldOffset(TopWnd.hProcess, VMT, 'FVolumeMeasured');
DumpArrayOfDouble(TopWnd.hProcess, Fld);
writeln(AngularMetterClassName, ':');
Ctrl := FindWinControl(TopWnd.Wnd, AngularMetterClassName, 0);
VMT := FindVmt(TopWnd.hProcess, Ctrl);
if not AnsiSameText(AngularMetterClassName, GetVmtClassName(TopWnd.hProcess, VMT))
then raise Exception.Create('ClassName mismatch');
//DumpFields(TopWnd.hProcess, VMT);
Fld := Ctrl + FindFieldOffset(TopWnd.hProcess, VMT, 'FValueClear');
if ReadBoolean(TopWnd.hProcess, Fld)
then writeln('-')
else begin
Fld := Ctrl + FindFieldOffset(TopWnd.hProcess, VMT, 'FValuePos');
DumpDouble(TopWnd.hProcess, Fld);
end;
finally
CloseHandle(TopWnd.hProcess)
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
readln
end.
|
|
При получении данных из чужой программы, нужно прочитать данные из контейнера .NET - WindowsForms10.Window.8.app.0.378734a - таблицу dspTestSeqGrid. Уже перепробовал разнообразную реализацию, но пока не нашел решения этой проблемы. 
