Seltsame Exception

[Der_Unwissende]

Ok, ich glaube ich verlier gerade ein wenig den überblick. Könntest du vielleicht das Programm posten? Das macht die Suche nach dem Fehler (denke ich) leichter.

[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.

[marabu]

Nebenbei bemerkt - die IF-Bedingung wird nie wahr:

Delphi-Quellcode:

repeat
  if LowerCase(ExtractFileExt(F.Name)) = '.DFP' then
    ProfileReader.ReadProfile(F.Name);
until FindNext(F) <> 0;

Grüße vom marabu

[Mystic]

Ähh.. hier stimmt was ganz gewaltig nicht.

Die IF-Bedingung sollte zwar nie wahr werden (wie du sagtest), aber sie wird IMMER wahr, egal was ich als string hinter dem = angebe.

[marabu]

Wahrlich - du machst deinem nick alle Ehre...

[jim_raynor]

Kann mir eigentlich nur vorstellen, dass ProfileApplyExecute vor dem FormCreate aufgerufen wird. Schon mal haltepunkt in Zeile 55 und 111 (nach dem Listing im Forum) gesetzt, und geschaut was zuerst aufgerufen wird?

P.S: Die IF-Bedingung kann nicht wahr werden, da du den String in klein-Buchstaben konvertierst und mit Groß-Buchstaben vergleichst ;)

[Mystic]

Mehr Mysterien:

Delphi-Quellcode:

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

Führt nur zu einer einzigen leeren ShowMessage-Box.

Im Verzeichnis ist eine einzige dfp-Datei (Balanced.dfp), die anscheinend richtig importiert wird.

/edit:

Ok, das lag an der Zeile:

Delphi-Quellcode:

ReadProfile(ExtractFilePath(ParamStr(0)) + 'Balanced.dfp');

edit/

Zitat:

Zitat von jim_raynor

Kann mir eigentlich nur vorstellen, dass ProfileApplyExecute vor dem FormCreate aufgerufen wird. Schon mal haltepunkt in Zeile 55 und 111 (nach dem Listing im Forum) gesetzt, und geschaut was zuerst aufgerufen wird?

P.S: Die IF-Bedingung kann nicht wahr werden, da du den String in klein-Buchstaben konvertierst und mit Groß-Buchstaben vergleichst ;)

Das Create wird zuerst aufgerufen.

[jim_raynor]

Du kannst bei FindFirst auch mit Erweiterung suchen, dann sparst du dir die Abfrage:

Delphi-Quellcode:

FindFirst(ExtractFilePath(Application.ExeName)+'*.dfp', faAnyFile, F);

(Kann sein, dass du vor dem Sternchen noch ein \ machen musst. Weiss jetzt nicht ob ExtractFilePath den Pfad mit oder ohne Backslash zurückgibt.

[marabu]

Hast du dir die Demo zu FindFirst() und Co. in der Delphi Online Hilfe schon mal angesehen?

marabu

[Mystic]

Zitat:

Zitat von marabu

Hast du dir die Demo zu FindFirst() und Co. in der Delphi Online Hilfe schon mal angesehen?

marabu

Hab ich, und jetzt funktioniert der Find*-Teil auch.

Zitat:

Zitat von jim_raynor

Du kannst bei FindFirst auch mit Erweiterung suchen, dann sparst du dir die Abfrage:

Delphi-Quellcode:

FindFirst(ExtractFilePath(Application.ExeName)+'*.dfp', faAnyFile, F);

(Kann sein, dass du vor dem Sternchen noch ein \ machen musst. Weiss jetzt nicht ob ExtractFilePath den Pfad mit oder ohne Backslash zurückgibt.

Hab ich gerade auf die gleiche Weise gelöst. ;)

Fehlt jetzt nur noch die AV.

edit:

AV weg! :-D

Habe WriteProfile verändert:

Delphi-Quellcode:

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