Seltsame Exception

[Mystic]

Gerne.

Delphi-Quellcode:

unit MainUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, XPMan, ExtCtrls, ActnList, StdActns, ComCtrls, ProfChanger;

type
  TMainForm = class(TForm)
    ButtonPanel: TPanel;
    MainPanel: TPanel;
    XPManifest: TXPManifest;
    DescriptionPanel: TPanel;
    ProfileTitleLabel: TLabel;
    ProfileDescriptionMemo: TMemo;
    ExitButton: TButton;
    MainSplitter: TSplitter;
    ApplyButton: TButton;
    ActionList: TActionList;
    FileExit: TFileExit;
    ProfileApply: TAction;
    ContainerPanel: TPanel;
    StatusBar: TStatusBar;
    ProfilesBox: TListView;
    procedure ProfileApplyExecute(Sender: TObject);
    procedure ProfilesBoxSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure ProfilesBoxResize(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
    ProfileWriter: TProfileWriter;
    ProfileReader: TProfileReader;
  public
    { Public-Deklarationen }
  end;

var
  MainForm: TMainForm;

procedure NvStartup; external 'nvcpl.dll';

implementation

{$R *.dfm}

procedure TMainForm.FormCreate(Sender: TObject);
var
  F: TSearchRec;
  i: integer;
  item: TListItem;
begin
  ProfileWriter := TProfileWriter.Create;
  ProfileReader := TProfileReader.Create;

  FindFirst(ExtractFilePath(Application.ExeName), faAnyFile, F);
  try
  repeat
    if LowerCase(ExtractFileExt(F.Name)) = '.DFP' then
      ProfileReader.ReadProfile(F.Name);
  until FindNext(F) <> 0;
  finally
    FindClose(F);
  end;

  with ProfileReader.Profiles do
    if Count > 0 then for i := 0 to Count - 1 do
    begin
      item := ProfilesBox.Items.Add;
      item.Caption := TProfile(Items[i]).Name;
      item.Data := Items[i];
    end else begin
      Application.MessageBox('No profiles found!','Fatal Error',16);
      Application.Terminate;
    end;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  ProfileReader.Free;
  ProfileWriter.Free;
end;

procedure TMainForm.ProfilesBoxResize(Sender: TObject);
begin
  ProfilesBox.Columns.Items[0].Width := ProfilesBox.ClientWidth;
end;

procedure TMainForm.ProfilesBoxSelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
var
  Profile: TProfile;
begin
  if Selected then
  begin
    Profile := Item.Data;
    ProfileTitleLabel.Caption := Profile.Name;
    ProfileDescriptionMemo.Lines.Assign(Profile.Desc);
    ApplyButton.Enabled := true;
  end else begin
    ProfileTitleLabel.Caption := '';
    ProfileDescriptionMemo.Clear;
    ApplyButton.Enabled := false;
  end;
end;

procedure TMainForm.ProfileApplyExecute(Sender: TObject);
begin
  ProfileWriter.WriteProfile(ProfilesBox.Selected.Data);
end;

end.

Delphi-Quellcode:

unit ProfChanger;

interface

uses
  Registry, IniFiles, Windows, Classes, SysUtils, Dialogs;

type
  TProfile = class
    public
      Name: string;
      Desc: TStringList;
      Settings: TStringList;
      constructor Create;
      destructor Destroy; override;
  end;

  TProfileWriter = class
    private
      Reg: TRegistry;
      Keys: TStringList;
      procedure FindKeys;
    public
      constructor Create;
      destructor Destroy; override;
      procedure WriteBinaryValue(const Name: string; var Value: array of byte);
      procedure WriteProfile(const Profile: TProfile);
  end;

  TProfileReader = class
    public
      Profiles: TList;
      procedure ReadProfile(const Filename: string);
      constructor Create;
      destructor Destroy; override;
  end;


implementation

procedure ReadREG_MULTI_SZ(const CurrentKey: HKey; const Subkey, ValueName: string; Strings: TStrings);
var
  valueType: DWORD;
  valueLen: DWORD;
  p, buffer: PChar;
  key: HKEY;
begin
  Strings.Clear;
  if RegOpenKeyEx(CurrentKey,
                  PChar(Subkey),
                  0, KEY_READ, key) = ERROR_SUCCESS then
  begin
    SetLastError(RegQueryValueEx(key,
                 PChar(ValueName),
                 nil,
                 @valueType,
                 nil,
                 @valueLen));
    if GetLastError = ERROR_SUCCESS then
      if valueType = REG_MULTI_SZ then
      begin
        GetMem(buffer, valueLen);
        try
          RegQueryValueEx(key,
                          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('Stringlist expected')
  end;
end;

{ TProfileWriter }

const
  ClassKey = '\Control\Class';
  VideoKey = '\Control\Video';
  nvKey    = '\Services\nv';

constructor TProfileWriter.Create;
begin
  inherited;
  Reg := TRegistry.Create;
  Keys := TStringList.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;

  FindKeys;
end;

destructor TProfileWriter.Destroy;
begin
  Keys.Free;
  Reg.Free;
  inherited;
end;

procedure TProfileWriter.FindKeys;
var
  i,j,k: cardinal;
  strs1,strs2,strs3,strs4: TStringList;
begin
  Keys.Clear;

  strs1 := TStringList.Create;
  strs2 := TStringList.Create;
  strs3 := TStringList.Create;
  strs4 := TStringList.Create;

  try
    with Reg do
    begin
      if OpenKey('\SYSTEM', false) and HasSubKeys then
      begin
        GetKeyNames(strs1);
        for i := 0 to strs1.Count - 1 do
          if OpenKey('\SYSTEM\' + strs1.Strings[i], false) and HasSubKeys and KeyExists('Control') then
          begin

            if OpenKey('\SYSTEM\' + strs1.Strings[i] + ClassKey, false) and HasSubKeys then
            begin
              GetKeyNames(strs2);
              for j := 0 to strs2.Count - 1 do
                if OpenKey('\SYSTEM\' + strs1.Strings[i] + ClassKey + '\' + strs2.Strings[j], false) and HasSubKeys then
                begin
                  GetKeyNames(strs3);
                  for k := 0 to strs3.Count - 1 do
                    if OpenKey('\SYSTEM\' + strs1.Strings[i] + ClassKey + '\' + strs2.Strings[j] + '\' + strs3.Strings[k] + '\Settings', false) then
                    begin
                      ReadREG_MULTI_SZ(HKEY_LOCAL_MACHINE,CurrentPath,'InstalledDisplayDrivers',strs4);
                      if (strs4.Count = 1) and (strs4.Strings[0] = 'nv4_disp') then
                        Keys.Add(CurrentPath);
                    end;
                end;
            end;

            if OpenKey('\SYSTEM\' + strs1.Strings[i] + VideoKey, false) and HasSubKeys then
            begin
              GetKeyNames(strs2);
              for j := 0 to strs2.Count - 1 do
                if OpenKey('\SYSTEM\' + strs1.Strings[i] + VideoKey + '\' + strs2.Strings[j], false) and HasSubKeys then
                begin
                  GetKeyNames(strs3);
                  for k := 0 to strs3.Count - 1 do
                    if OpenKey('\SYSTEM\' + strs1.Strings[i] + VideoKey + '\' + strs2.Strings[j] + '\' + strs3.Strings[k], false) then
                    begin
                      ReadREG_MULTI_SZ(HKEY_LOCAL_MACHINE,CurrentPath,'InstalledDisplayDrivers',strs4);
                      if (strs4.Count = 1) and (strs4.Strings[0] = 'nv4_disp') then
                        Keys.Add(CurrentPath);
                    end;
                end;
            end;

            if OpenKey('\SYSTEM\' + strs1.Strings[i] + nvKey, false) and HasSubKeys then
            begin
              GetKeyNames(strs2);
              for j := 0 to strs2.Count - 1 do
                if OpenKey('\SYSTEM\' + strs1.Strings[i] + nvKey + '\' + strs2.Strings[j], false) then
                begin
                  ReadREG_MULTI_SZ(HKEY_LOCAL_MACHINE,CurrentPath,'InstalledDisplayDrivers',strs3);
                  if (strs3.Count = 1) and (strs3.Strings[0] = 'nv4_disp') then
                    Keys.Add(CurrentPath);
                end;
            end;
          end;
      end;
      CloseKey;
    end;

  finally
    strs4.Free;
    strs3.Free;
    strs2.Free;
    strs1.Free;
  end;
end;

procedure TProfileWriter.WriteBinaryValue(const Name: string; var Value: array of byte);
var
  i: cardinal;
begin
  if not assigned(keys) then
  begin
    ShowMessage('NACHRICHT');
  end;
  if (Keys.Count > 0) and (Length(Value) > 0) then
    for i := 0 to Keys.Count - 1 do begin
      Reg.OpenKey(Keys.Strings[i], false);
      Reg.WriteBinaryData(Name,Value[0],Length(Value));
      Reg.CloseKey;
    end;
end;

procedure TProfileWriter.WriteProfile(const Profile: TProfile);
var
  pc: PAnsiChar;
  a: array of byte;
  i: cardinal;
begin
  SetLength(a, 4);
  GetMem(pc, 5);
  try
    FillChar(pc,5,0);
    with Profile.Settings do
    begin
      if Count > 0 then for i := 0 to Count - 1 do
      begin
        pc := PChar(LowerCase(ValueFromIndex[i]));
        HexToBin(pc,pc,4);
        CopyMemory(@a[0],pc,4);
        WriteBinaryValue(Names[i],a);
      end;
    end;
  finally
    FreeMem(pc);
  end;
end;

{ TProfile }

constructor TProfile.Create;
begin
  inherited;
  Desc := TStringList.Create;
  Settings := TStringList.Create;
end;

destructor TProfile.Destroy;
begin
  Settings.Free;
  Desc.Free;
  inherited;
end;

{ TProfileReader }

constructor TProfileReader.Create;
begin
  inherited;
  Profiles := TList.Create;
  ReadProfile(ExtractFilePath(ParamStr(0)) + 'Balanced.dfp');
end;

destructor TProfileReader.Destroy;
var i: integer;
begin
  if Profiles.Count > 0 then for i := 0 to Profiles.Count - 1 do
    TProfile(Profiles.Items[i]).Free;
  Profiles.Free;
  inherited;
end;

procedure TProfileReader.ReadProfile(const Filename: string);
var
  Ini: TIniFile;
  Prof: TProfile;
  strs1: TStringList;
  i: cardinal;
  s: string;
begin
  Ini := TIniFile.Create(Filename);
  strs1 := TStringList.Create;

  with Ini do
    try
      Prof := TProfile.Create;
      try
        ReadSections(strs1);
        if strs1.Count = 2 then
        begin
          Prof.Name := strs1.Strings[0];
          ReadSection(Prof.Name,strs1);
          if strs1.Count > 0 then for i := 0 to strs1.Count - 1 do
            Prof.Desc.Add(ReadString(Prof.Name, strs1.Strings[i], ''));
          ReadSection('Values',strs1);
          if strs1.Count > 0 then
            for i := 0 to strs1.Count - 1 do
            begin
              Prof.Settings.Add(strs1.Strings[i] + '=' + ReadString('Values',strs1.Strings[i],'00000000'))
            end
          else
            raise Exception.Create('No values in profile file "' + Filename + '"!');
          Profiles.Add(Prof);
        end else
          raise Exception.Create('Invalid profile file "' + Filename + '"!');
      except
        Prof.Free;
      end;
    finally
      strs1.Free;
      Ini.Free;
    end;
end;

end.