オブジェクトツリーを印刷するには？ (ID：25136)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

オブジェクトツリーのItemをMemoに。(Win9X系は実行不可)
未整形でチト見づらい？

type
  PInfo = ^TInfo;
  TInfo = packed record
    infoItem: TTVItem;
    infoText: array[0..255] of Char;
  end;
const
  MAXTEXTLEN = 50;
var
  hProcess : THandle;
  SysShared: PByte;
  sNode: string;
  Level: Integer;
  sDir: array[0..31]of string;
  hChild: HWND;

function GetItemByNameNT(Wnd: hWnd; hItem: HTREEITEM): HTREEITEM;
var
  info: TInfo;
  szBuffer: array [0..MAXTEXTLEN+1] of Char;
  hItemFound, hItemChild: HTREEITEM;
  BytesRW: Dword;
begin
  if (hItem = nil) then begin
    hItem := HTREEITEM(SendMessage(Wnd, TVM_GETNEXTITEM, TVGN_ROOT, 0));
    sNode := '';
    Level := 0;
  end;
  with Info do begin
    while (hItem <> nil) do begin
      infoItem.hItem := hItem;
      infoItem.mask := TVIF_TEXT or TVIF_CHILDREN;
      infoItem.pszText := PInfo(SysShared).infoText;
      infoItem.cchTextMax := MAXTEXTLEN;
      Win32Check(WriteProcessMemory(hProcess, SysShared, @Info, Sizeof(Info), BytesRW));
      SendMessage(Wnd, TVM_GETITEM, 0, LPARAM(SysShared));
      Win32Check(ReadProcessMemory(hProcess, SysShared, @Info, Sizeof(Info), BytesRW));

if (infoItem.cChildren > 0) then begin
        if sNode = '' then begin
          sNode := infoText;
        end else begin
          sNode := sNode +' ⇒ '+ infoText;
        end;
        inc(Level); sDir[Level] := sNode;
        // 再帰コール
        hItemChild := HTREEITEM(SendMessage(Wnd, TVM_GETNEXTITEM, TVGN_CHILD, Longint(hItem)));
        GetItemByNameNT(Wnd, hItemChild);
      end else begin
        if sNode <> '' then Form1.Memo1.Lines.Add(sNode +' ⇒ '+ infoText);
      end;
      hItem := HTREEITEM(SendMessage(Wnd, TVM_GETNEXTITEM, TVGN_NEXT, LPARAM(hItem)));
    end;
    dec(Level);
    if Level > 0 then begin
      sNode	:= sDir[Level];
    end else begin
      sNode := '';
    end;
  end;
  result := nil;
end;

function EnumChildFunc(hW: HWND; LParam: Pointer): BOOL; stdcall;
var
  szClassName: array[0..255]of Char;
begin
  if hW <> 0 then begin
    GetClassName(hW, szClassName, 255);
    if szClassName = 'TTreeView' then begin
      hChild := hW;
      Result := True;
    end;
  end else Result:= False;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hItem : HTREEITEM;
  hw,hw2: HWND;
  pid: Integer;
begin
  Memo1.Clear;
  hChild := 0;
  hw := FindWindow('TObjectTreeView', nil);  // オブジェクトツリーのウィンドゥハンドル
  GetWindowThreadProcessId(hw, @pid);
  if (hw = 0)or(pid = 0) then exit;

hProcess := OpenProcess(PROCESS_ALL_ACCESS, FALSE, pid);
  if (hProcess = 0) then RaiseLastWin32Error;
  SysShared := VirtualAllocEx(hProcess, nil, SizeOf(TInfo)+1, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  if Assigned(SysShared) then begin
    EnumChildWindows(hw, @EnumChildFunc, 0);
    hItem := GetItemByNameNT(hChild, nil);
    Win32Check(Boolean(VirtualFreeEx(hProcess, SysShared, 0, MEM_RELEASE)));
  end;
  CloseHandle(hProcess);
end;

←解決時は質問者本人がここをチェックしてください。

戻る