unitexregistry.pas

操作远程注册表样例

    if st = '' then
      SyntaxError;

    r := RootKeyVal (s);
    if r = $ffffffff then
      SyntaxError;

    SetRoot (r, fSaveServer);
    OpenKey ('\' + st, True)
  end;

  function GetCString (const st : string) : string;
  var
    i : Integer;
  begin
    result := '';
    i := 2;
    while i <= Length (st) - 1 do
    begin
      if st [i] = '\' then
        Inc (i);

      if i <= Length (st) - 1 then
        result := result + st [i];

      Inc (i)
    end
  end;

  function GetBinaryBuffer (const st : string) : string;
  var
    i : Integer;
    val : string;
  begin
    i := 1;
    result := '';
    while i <= Length (st) do
    begin
      if st [i] in ['0'..'9', 'a'..'f', 'A'..'F'] then
        val := val + st [i]
      else
      begin
        if val <> '' then
        begin
          result := result + chr (StrToInt ('$' + val));
          val := ''
        end
      end;

      Inc (i)
    end
  end;

  procedure CreateNewValue;
  var
    s : string;
    fn : string;
    p : Integer;
    tp : Integer;
    buf : string;
  begin
    if st [1] = '"' then
    begin
      Delete (st, 1, 1);
      p := Pos ('"', st);
      if p = 0 then
        SyntaxError;

      s := Copy (st, 1, p - 1);
      st := Copy (st, p + 1, MaxInt)
    end
    else
    begin
      Delete (st, 1, 1);
      s := ''
    end;

    st := TrimLeft (st);

    if st = '' then
      SyntaxError;

    if st [1] <> '=' then
      SyntaxError;

    Delete (st, 1, 1);

    st := TrimLeft (st);

    if st [1] = '"' then
      WriteString (s, GetCString (st))
    else
    begin
      p := 1;
      while (p <= Length (st)) and not (st [p] in [':', '(', ' ']) do
        Inc (p);

      fn := Copy (st, 1, p - 1);

      st := TrimLeft (Copy (st, p, MaxInt));

      if CompareText (fn, 'hex') = 0 then
      begin
        tp := 3;
        if st [1] = '(' then
        begin
          Delete (st, 1, 1);
          fn := '';
          p := 1;
          while (p <= Length (st)) and (st [p] <> ')') do
          begin
            fn := fn + st [p];
            Inc (p)
          end;

          tp := StrToInt (fn);
          st := Trim (Copy (st, p + 1, MaxInt));
        end;

        if st [1] <> ':' then
          SyntaxError;

        Delete (st, 1, 1);

        buf := GetBinaryBuffer (st);

        WriteTypedBinaryData (s, tp, PChar (buf)^, Length (buf));
      end
      else
        if CompareText (fn, 'dword') = 0 then
        begin
          if st [1] <> ':' then
            SyntaxError;

          Delete (st, 1, 1);
          WriteInteger (s, StrToInt ('$' + TrimLeft (st)))
        end
        else
          SyntaxError
    end
  end;

begin
  strings := TStringList.Create;
  try
    strings.LoadFromFile (fileName);

    while (strings.Count > 0) do
    begin
      st := Trim (strings [0]);
      if (st = '') or (st [1] = ';') then
        strings.Delete (0)
      else
        break
    end;

    if strings [0] <> 'REGEDIT4' then
      raise Exception.Create ('Bad file format.  Missing REGEDIT4 in first line.');

    i := 1;
    while i < strings.Count do
    begin
      st := Trim (strings [i]);

      if st <> '' then
        while st [Length (st)] = '\' do
        begin
          Inc (i);
          Delete (st, Length (st), 1);
          if i < strings.Count then
            st := st + strings [i]
          else
            break
        end;

      if (Length (st) > 0) and (st [1] <> ';') then
      begin
        case st [1] of
          '[' : CreateNewKey;
          '"' : CreateNewValue;
          '@' : CreateNewValue;
          else
            SyntaxError
        end
      end;

      Inc (i)
    end
  finally
    strings.Free
  end
end;

procedure TExRegistry.ReadStrings(const valueName: string;
  strings: TStrings);
var
  valueType : DWORD;
  valueLen : DWORD;
  p, buffer : PChar;
begin
  strings.Clear;
  SetLastError (RegQueryValueEx (CurrentKey, PChar (valueName), Nil, @valueType, Nil, @valueLen));
  if GetLastError = ERROR_SUCCESS then
    if valueType = REG_MULTI_SZ then
    begin
      GetMem (buffer, valueLen);
      try
        RegQueryValueEx (CurrentKey, PChar (valueName), Nil, Nil, PBYTE (buffer), @valueLen);
        p := buffer;
        while p^ <> #0 do
        begin
          strings.Add (p);
          Inc (p, lstrlen (p) + 1)
        end
      finally
        FreeMem (buffer)
      end
    end
    else
      raise ERegistryException.Create ('String list expected')
  else
    raise EExRegistryException.CreateLastError ('Unable read MULTI_SZ value')
end;

procedure TExRegistry.SetRoot(root: HKey; const server: string);
begin
  fSaveServer := server;
  RootKey := root;
  fLocalRoot := root;
  if server <> '' then
    if not RegistryConnect ('\\' + server) then
      Raise Exception.CreateFmt (errUnableToConnect, [server, GetLastError])
end;

procedure TExRegistry.ValuesSizeProc(const keyName, valueName: string;
  dataType: DWORD; data: pointer; DataLen: Integer);
begin
  Inc (fValuesSize, DataLen);
end;

procedure TExRegistry.Walk(walkProc: TWalkProc; valuesRequired : boolean);

var
  defaultValue : array [0..256] of char;
  defaultValueLen : DWORD;

  valueName : array [0..256] of char;
  valueNameLen : DWORD;

  keyName : array [0..256] of char;

  cValues : DWORD;
  tp : DWORD;

  buffer : PChar;
  bufSize : DWORD;

  valueLen, maxValueLen : DWORD;
  keyLen : DWORD;

  procedure DoWalk (const pathName : string);
  var
    k : HKEY;
    err : Integer;
    i : Integer;
    cSubKeys : DWORD;
  begin
    err := RegOpenKeyEx (RootKey, PChar (pathName), 0, KEY_READ, k);
    if err = ERROR_SUCCESS then
    try
      defaultValueLen := sizeof (defaultValue);

      err := RegQueryInfoKey (k, defaultValue, @defaultValueLen, Nil, @cSubkeys, Nil, Nil, @cValues, nil, @maxValueLen, nil, nil);
      if (err <> ERROR_SUCCESS) and (err <> ERROR_ACCESS_DENIED) then
        raise EExRegistryException.Create (err, 'Unable to query key info');

      if err = ERROR_SUCCESS then
      begin
        if cValues > 0 then
        begin
          if maxValueLen > bufSize then
          begin
            bufSize := 65536 * ((maxValueLen + 65536) div 65536);
            ReallocMem (buffer, bufSize)
          end;

          for i := 0 to cValues - 1 do
          begin
            valueNameLen := sizeof (valueName);
            valueLen := maxValueLen;
            if valuesRequired then
              err := RegEnumValue (k, i, valueName, valueNameLen, Nil, @tp, PByte (buffer), @valueLen)
            else
              err := RegEnumValue (k, i, valueName, valueNameLen, Nil, @tp, Nil, @valueLen);
            if err <> ERROR_SUCCESS then
              raise EExRegistryException.Create (err, 'Unable to get value info');

            walkProc (pathName, valueName, tp, buffer, valueLen);
          end
        end
        else
          walkProc (pathName, '', 0, Nil, 0);

        for i := 0 to cSubkeys - 1 do
        begin
          keyLen := sizeof (keyName);
          RegEnumKey (k, i, keyName, keyLen);
          if pathName = '' then
            DoWalk (keyName)
          else
            DoWalk (pathName + '\' + keyName)
        end
      end
    finally
      RegCloseKey (k);
    end
//    else
//      if err <> 161 then
//        raise EExRegistryException.Create (err, 'Unable to open key')
  end;

begin
  bufSize := 65536;
  GetMem (buffer, bufSize);

  try
    if Assigned (walkProc) then
      DoWalk (CurrentPath);
  finally
    FreeMem (buffer)
  end
end;

procedure TExRegistry.WriteStrings(const valueName: string;
  strings: TStrings);
var
  p, buffer : PChar;
  i : Integer;
  size : DWORD;
begin
  size := 0;
  for i := 0 to strings.Count - 1 do
    Inc (size, Length (strings [i]) + 1);
  Inc (size);
  GetMem (buffer, size);
  try
    p := buffer;
    for i := 0 to strings.count - 1 do
    begin
      lstrcpy (p, PChar (strings [i]));
      Inc (p, lstrlen (p) + 1)
    end;
    p^ := #0;
    SetLastError (RegSetValueEx (CurrentKey, PChar (valueName), 0, REG_MULTI_SZ, buffer, size));
    if GetLastError <> ERROR_SUCCESS then
      raise EExRegistryException.CreateLastError ('Unable to write MULTI_SZ value');
  finally
    FreeMem (buffer)
  end
end;

procedure TExRegistry.WriteTypedBinaryData(const valueName: string;
  tp: Integer; var data; size: Integer);
begin
  if RegSetValueEx (CurrentKey, PChar(valueName), 0, tp, @data, size) <> ERROR_SUCCESS then
    raise ERegistryException.CreateFmt('Unable to set registry data for %s', [valueName]);
end;

{ EExRegistryException }

constructor EExRegistryException.Create(code: DWORD; const st: string);
begin
  fCode := code;
  inherited Create (GetError + ':' + st);
end;

constructor EExRegistryException.CreateLastError(const st: string);
begin
  fCode := GetLastError;
  inherited Create (GetError + ':' + st);
end;

function EExRegistryException.GetError: string;
var
  msg : string;

  function GetErrorMessage (code : Integer) : string;
  var
    hErrLib : THandle;
    msg : PChar;
    flags : Integer;

    function MAKELANGID (p, s : word) : Integer;
    begin
      result := (s shl 10) or p
    end;

  begin
    hErrLib := LoadLibraryEx ('netmsg.dll', 0, LOAD_LIBRARY_AS_DATAFILE);

    try

      flags := FORMAT_MESSAGE_ALLOCATE_BUFFER or
               FORMAT_MESSAGE_IGNORE_INSERTS or
               FORMAT_MESSAGE_FROM_SYSTEM;

      if hErrLib <> 0 then
        flags := flags or FORMAT_MESSAGE_FROM_HMODULE;

      if FormatMessage (flags, pointer (hErrLib), code,
                        MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
                        PChar (@msg), 0, Nil) <> 0 then
        try
          result := msg;

        finally
          LocalFree (Integer (msg));
        end

    finally
      if hErrLib <> 0 then
        FreeLibrary (hErrLib)
    end
  end;

begin
  msg := GetErrorMessage (fCode);
  if msg = '' then
    result := Format ('Error %d', [fCode])
  else
    result := Format ('Error %d : %s', [fCode, msg])
end;

{ TSearchNode }

constructor TSearchNode.Create (ARegRoot : HKEY; const APath : string);
begin
  fRegRoot := ARegRoot;
  fValueIDX := -1;
  fKeyIdx := -1;
  fPath := APath
end;

destructor TSearchNode.Destroy;
begin
  fValueNames.Free;
  fKeyNames.Free;
  inherited Destroy
end;

procedure TSearchNode.LoadKeyNames;
var
  r : TExRegistry;
  i : Integer;
begin
  if not Assigned (fKeyNames) then
  begin
    fKeyNames := TStringList.Create;
    r := TExRegistry.Create;
    try
      r.RootKey := fRegRoot;
      r.OpenKey (fPath, False);
      r.GetKeyNames (fKeyNames);
    finally
      r.Free
    end;
    
    for i := 0 to fKeyNames.Count - 1 do
      fKeyNames [i] := UpperCase (fKeyNames [i]);
  end
end;

procedure TSearchNode.LoadValueNames;
var
  r : TExRegistry;
  i : Integer;
begin
  if not Assigned (fValueNames) then
  begin
    fValueNames := TStringList.Create;
    r := TExRegistry.Create;
    try
      r.RootKey := fRegRoot;
      r.OpenKey (fPath, False);
      r.GetValueNames (fValueNames);
    finally
      r.Free
    end;

    for i := 0 to fValueNames.Count - 1 do
      fValueNames [i] := UpperCase (fValueNames [i]);
  end
end;

end.