mitec_pe.pas

MiTeC.System.Information.v10.7.0.FS 检测系统硬件信息的DELPHI控件

      Inc(P);
    Inc(Cnt);
  end;
end;

procedure SaveResourceAsAccelerators;
var
  TableEntry: PAccelTableEntry;
  IsLast: Boolean;
  S: string;

  function AnsiToChar(A: Word): string;
  begin
    if A>=32 then
      Result:=Chr(A)
    else
      Result:='';
  end;

  function VirtualKeyNameFromCode(KeyCode: Byte): string;
  const
  KN002F: array[$00..$2F] of PChar = (
    nil,
    'LBUTTON',
    'RBUTTON',
    'CANCEL',
    'MBUTTON',
    nil, nil, nil, // 05..07
    'BACK',
    'TAB',
    nil, nil, // 0A..0B
    'CLEAR',
    'RETURN',
    nil, nil, // 0E..0F
    'SHIFT ',
    'CONTROL',
    'MENU',
    'PAUSE',
    'CAPITAL',
    'KANA',
    'HANGUL',
    'JUNJA',
    'FINAL',
    'HANJA',
    'KANJI',
    'ESCAPE',
    'CONVERT',
    'NONCONVERT',
    'ACCEPT',
    'MODECHANGE',
    'SPACE',
    'PRIOR',
    'NEXT',
    'END',
    'HOME',
    'LEFT',
    'UP',
    'RIGHT',
    'DOWN',
    'SELECT',
    'PRINT',
    'EXECUTE',
    'SNAPSHOT',
    'INSERT',
    'DELETE',
    'HELP'
    );
  KN5B5D: array[$5B..$5D] of PChar = (
    'LWIN',
    'RWIN',
    'APPS'
    );
  KN6A6F: array[$6A..$6F] of PChar = (
    'MULTIPLY',
    'ADD',
    'SEPARATOR',
    'SUBTRACT',
    'DECIMAL',
    'DIVIDE'
    );
  KNA0A5: array[$A0..$A5] of PChar = (
    'LSHIFT',
    'RSHIFT',
    'LCONTROL',
    'RCONTROL',
    'LMENU',
    'RMENU'
    );
  KNF6FE: array[$F6..$FE] of PChar = (
    'ATTN',
    'CRSEL',
    'EXSEL',
    'EREOF',
    'PLAY',
    'ZOOM',
    'NONAME',
    'PA1',
    'OEM_CLEAR'
    );
begin
  case KeyCode of
    $00..$2F:
      Result := KN002F[KeyCode];
    $30..$39, $41..$5A:
      Result := Chr(KeyCode);
    $5B..$5D:
      Result := KN5B5D[KeyCode];
    $60..$69:
      Result := Format('NUMPAD%d', [KeyCode - $60]);
    $6A..$6F:
      Result := KN6A6F[KeyCode];
    $70..$87:
      Result := Format('F%d', [KeyCode - $6F]);
    $90:
      Result := 'NUMLOCK';
    $91:
      Result := 'SCROLL';
    $A0..$A5:
      Result := KNA0A5[KeyCode];
    $E5:
      Result := 'PROCESSKEY';
    $F6..$FE:
      Result := KNF6FE[KeyCode];
  else
    Result := '';
  end;
  if Result <> '' then Result := 'VK_' + Result;
end;

begin
  ADest.BeginUpdate;
  try
    TableEntry:=ASource.Memory;
    repeat
      with TableEntry^ do  begin
        IsLast:=fFlags and $80<>0;
        if fFlags and FVIRTKEY<>0 then begin
          S:=Format('Virtual Key: %.2u "%s" ',[wAnsi,VirtualKeyNameFromCode(wAnsi)]);
          if fFlags and FSHIFT<>0 then
            S:=S+'SHIFT ';
          if fFlags and FCONTROL<>0 then
            S:=S+'CTRL ';
          if fFlags and FALT<>0 then
            S:=S+'ALT ';
        end else
          S:=Format('ANSI character: %.2u "%s" ',[wAnsi,AnsiToChar(wAnsi)]);
        if fFlags and FNOINVERT<>0 then
          S:=S+'NOINVERT';
      end;
      ADest.Add(TrimRight(S));
      Inc(TableEntry);
    until IsLast;
  finally
    ADest.EndUpdate;
  end;
end;

procedure SaveResourceAsMessageTable;
var
  Count,I: Integer;
  E: DWORD;
  Block: PMessageResourceBlock;
  Entry: PMessageResourceEntry;
  S: string;
  Text: PChar;
  Data: Pointer;
begin
  Data:=ASource.Memory;
  Count:=PMessageResourceData(Data)^.NumberOfBlocks;
  Block:=Data;
  Inc(PMessageResourceData(Block));
  for I:=1 to Count do begin
    Entry:=PMessageResourceEntry(DWORD(Data) + Block^.OffsetToEntries);
    for E:=Block^.LowId to Block^.HighId do begin
      with Entry^ do begin
        Text:=PChar(Entry)+Sizeof(TMessageResourceEntry);
        if Flags=1 then
          S:=WideCharLenToString(PWideChar(Text),lstrlenW(PWideChar(Text)))
        else
          SetString(S,PAnsiChar(Text),StrLen(Text));
        S:=Trim(S);
        ADest.Add(S);
      end;
      Entry:=Pointer(PChar(Entry)+Entry^.Length);
    end;
    Inc(Block);
  end;
end;

procedure SaveResourceAsIcon(ASource: TResourceStream; ADest: TStream);
begin
  with TIcon.Create do
    try
      Handle:=CreateIconFromResource(ASource.Memory,ASource.Size,True,$30000);
      SaveToStream(ADest);
      ADest.Position:=0;
    finally
      Free;
    end;
end;

function IMAGE_ORDINAL(Ordinal: DWORD): DWORD;
begin
  Result:=(Ordinal and $0000FFFF);
end;

function GetResourceTypeName;
var
  i: Integer;
begin
  Result:='';
  for i:=0 to High(cResources) do
    if Longint(cResources[i].ID)=Longint(ATyp) then begin
      Result:=cResources[i].Name;
      Break;
    end;
end;


function DirectoryNames(Directory: Word): string;
begin
  case Directory of
    IMAGE_DIRECTORY_ENTRY_EXPORT:
      Result := 'Exports';
    IMAGE_DIRECTORY_ENTRY_IMPORT:
      Result := 'Imports';
    IMAGE_DIRECTORY_ENTRY_RESOURCE:
      Result := 'Resources';
    IMAGE_DIRECTORY_ENTRY_EXCEPTION:
      Result := 'Exceptions';
    IMAGE_DIRECTORY_ENTRY_SECURITY:
      Result := 'Security';
    IMAGE_DIRECTORY_ENTRY_BASERELOC:
      Result := 'Base Relocations';
    IMAGE_DIRECTORY_ENTRY_DEBUG:
      Result := 'Debug';
    IMAGE_DIRECTORY_ENTRY_COPYRIGHT:
      Result := 'Description';
    IMAGE_DIRECTORY_ENTRY_GLOBALPTR:
      Result := 'Machine Value';
    IMAGE_DIRECTORY_ENTRY_TLS:
      Result := 'Thread Local Storage';
    IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG:
      Result := 'Load configuration';
    IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT:
      Result := 'Bound Import';
    IMAGE_DIRECTORY_ENTRY_IAT:
      Result := 'Import Address Table';
    IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT:
      Result := 'Delay load import';
    IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR:
      Result := 'COM run-time';
  else
    Result := Format('reserved [%.2d]', [Directory]);
  end;
end;


{ TMiTeC_PE }

procedure GetPackageInfoProc1(const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer);
begin
  with TStringList(Param) do
    case NameType of
      ntRequiresPackage: Add(Name);
    end;
end;
procedure GetPackageInfoProc2(const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer);
begin
  with TStringlist(Param) do
    case NameType of
      ntContainsUnit: Add(Name);
    end;
end;

function EnumResNameProc1(hModule : THandle; lpszType, lpszName : pchar; lParam : longint) : boolean; stdcall;
var
  rs: TResourceStream;
  s: string;
  Buf: Cardinal;
begin
  if longint(lpszName)<65535 then
    s:=IntToStr(longint(lpszName))
  else
    s:=string(lpszName);

  rs:=TResourceStream.Create(hModule,s,RT_RCDATA);
  try
    if (rs.Read(Buf,4)=4) and (Buf=DFM_Signature) then
      TStringList(lParam).Add(s);
  finally
    rs.Free;
  end;
  Result:=True;
end;

function EnumResNameProc2(hModule : THandle; lpszType, lpszName : pchar; lParam : longint) : boolean; stdcall;
var
  s: string;
begin
  if longint(lpszName)<65535 then
    s:=IntToStr(longint(lpszName))
  else
    s:=string(lpszName);

  if s<>'' then begin
    SetLength(PResourceData(lParam)^,Length(PResourceData(lParam)^)+1);
    with PResourceData(lParam)^[High(PResourceData(lParam)^)] do begin
      Typename:=GetResourceTypeName(lpszType);
      Typ:=Longint(lpszType);
      Name:=s;
    end;
  end;
  Result:=True;
end;

procedure TMiTeC_PE.Close;
begin
  if (FH>0) and not FKeep then
    FreeLibrary(FH);
  FFilename:='';
  FCL.Clear;
  FRP.Clear;
  FCU.Clear;
  FDFM.Clear;
  FHDR.Clear;
  FVER.Clear;
  Finalize(FRD);
  Finalize(FET);
  Finalize(FIT);
  FDesc:='';
  FH:=0;
end;

constructor TMiTeC_PE.Create;
begin
  FKeep:=False;
  FH:=0;
  FCL:=TList.Create;
  FRP:=TStringList.Create;
  FCU:=TStringList.Create;
  FDFM:=TStringList.Create;
  FHDR:=TStringList.Create;
  FVER:=TStringList.Create;
end;

procedure TMiTeC_PE.CreateClassList;
var
  pStart,pEnd,p: Pointer;

  function InRangeOrNil(APointer, pMin, pMax: Pointer): Boolean;
  begin
    Result:= (APointer=nil) or
             ((Integer(Apointer)>=Integer(pMin)) and
              (Integer(Apointer)<=Integer(pMax)))
  end;

  function IsIdent(p: PChar): Boolean;
  var
    i: Integer;
  begin
    Result:= False;
    i:=1;
    if (Ord(p^)>0) and ((p+1)^ in ['A'..'Z', 'a'..'z', '_']) then
      while (i<Ord(p^)) do begin
        Inc(i);
        Result:=((p+I)^ in ['0'..'9', 'A'..'Z', 'a'..'z', '_']);
      end;
  end;

  function isVirtualMethodTable: Boolean;
  begin
    Result:=Integer(p^)=Integer(p)-vmtSelfPtr;
  end;

  function InRangeOrNilTableElements: Boolean;

    function Sub_InRangeOrNilTableElements(Elements: Array of Integer; pMin: Pointer): Boolean;
    var
      i: Integer;
    begin
      Result:= True;
      i:=0;
      while (Result and (i<High(Elements))) do begin
        Result:=InRangeOrNil(Pointer(Pointer(Integer(p^)+Elements[i])^),pMin,pEnd);
        Inc(i);
      end;
    end;

  const
    ElementsFurtherInCode: Array[0..3] of Integer = (vmtClassName, vmtDynamicTable, vmtMethodTable, vmtFieldTable);
    ElementsAnyPartOfCode: Array[0..3] of Integer = (vmtTypeInfo, vmtInitTable, vmtAutoTable, vmtIntfTable);

  begin
    Result:=Sub_InRangeOrNilTableElements(ElementsFurtherInCode, Pointer(p^)) and
            Sub_InRangeOrNilTableElements(ElementsAnyPartOfCode, pStart);
  end;

  function isClassIdent: Boolean;
  begin
    Result:= IsIdent(PChar(Pointer(Integer(p^)+vmtClassName)^));
  end;

begin
  if SectionExists(SCODESectionTag,pStart) or SectionExists(SDotTextSectionTag,pStart) then begin
    pEnd:=Pointer(FH+PImageSectionHeader(pStart)^.VirtualAddress+(PImageSectionHeader(pStart)^.SizeOfRawData-SizeOf(Pointer)));
    pStart:=Pointer(FH+PImageSectionHeader(pStart)^.VirtualAddress);
    p:=pStart;
    while Integer(p)<Integer(pEnd) do begin
      if isVirtualMethodTable and InRangeOrNilTableElements and isClassIdent then
        FCL.Add(TClass(p^));
      Inc(Integer(p), SizeOf(Pointer));
    end;
  end;
end;

procedure TMiTeC_PE.CreateExportList;
var
  FExportDir: PImageExportDirectory;
  i: Integer;
  Names: PCardinal;
  NameOrdinals: PWORD;
  Functions: Cardinal;
begin
  FExportDir:=PImageExportDirectory(DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_EXPORT));
  Names:=RvaToVa(Cardinal(FExportDir.AddressOfNames));
  NameOrdinals:=RvaToVa(Cardinal(FExportDir^.AddressOfNameOrdinals));
  Functions:=Cardinal(RvaToVa(Cardinal(FExportDir^.AddressOfFunctions)));
  for i:=0 to FExportDir.NumberOfFunctions-1 do begin
    SetLength(FET,Length(FET)+1);
    with FET[High(FET)] do begin
      Name:=string(PChar(FH+Cardinal(Names^)));
      Ordinal:=NameOrdinals^+FExportDir^.Base;
      Address:=PCardinal(Functions+NameOrdinals^*SizeOf(Cardinal))^;
    end;
    Inc(Names);
    Inc(NameOrdinals);
  end;
end;

procedure TMiTeC_PE.CreateImportList;

function AddItem(Aname: string; AThunk: PImageThunkData): integer;
var
  idx,i: Integer;