Ce code provoque des violations

**Cazaux-Moutou-Philippe** · 04/12/2008, 18h56

Bonjour

ce code me provoque des violations, il sert a afficher dans un menu le nom et l icône des dll présente dans un répertoire

Merci de m'aider

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
procedure TFMain.DoInitAddon;
var
  HAddOn: THandle;
  i: integer;
  S: TStringList;
  AskTitle: string;
  Menu: TdxBarButton;
  Link: TdxBarItemLink;
  NbIcon: hicon;
  Icon: TIcon;
  mot: word;
  nIco: Integer;
 
begin
 
  HAddOn := 0;
  mot := 0;
 
  mAddon.ItemLinks.Clear;
 
  //Scanne le repertoire et met les chemins dans une TStringList
  s := TStringList.Create;
  LoadStringListWithFichier(_Path_Appli + _REL_PATH_PLUGINS + '*.dll', s);
  Application.ProcessMessages;
 
  with dxBarManager do
    begin
      LockUpdate := True;
 
      for i := 0 to S.Count - 1 do
        begin
          try
 
            HAddOn := LoadLibrary(PChar(_Path_Appli + _REL_PATH_PLUGINS + S.Strings[i]));
 
            if HAddOn <> 0 then
              begin
 
                AskTitle := TinitTitre(GetProcAddress(HAddOn, 'InitTitreDll'));
                Menu := TdxBarButton.Create(dxBarManager);
                Menu.Caption := AskTitle;
                Menu.OnClick := OnClickDll;
                Menu.Description := S.Strings[i];
 
                Link := mAddon.ItemLinks.Add;
                Link.Item := Menu;
 
                if upperCase(S.Strings[i]) = upperCase('DLLCreationWeb.dll') then
                  begin
                    ImageWeb.Visible := True;
                    lExportWeb.Visible := True;
                    lExportWeb.Tag := 999;
                    lExportWeb.Hint := S.Strings[i];
                    lExportWeb.OnClick := OnClickDll;
                  end;
 
                if upperCase(S.Strings[i]) = upperCase('DLLArbre.dll') then
                  begin
                    Image9.Visible := True;
                    Label5.Visible := True;
                    Label5.Tag := 998;
                    Label5.Hint := S.Strings[i];
                    Label5.OnClick := OnClickDll;
                  end;
 
                if upperCase(S.Strings[i]) = 'DLLSTATISTIQUES.DLL' then
                  Link.BeginGroup := True;
 
                NbIcon := ExtractIcon(HINSTANCE, Pchar(_Path_Appli + _REL_PATH_PLUGINS + S.Strings[i]), UINT(-1)); //ExtractIcon(0, PChar(S.Strings[i]), $FFFFFFFF);
 
                if NbIcon = 0 then
                  Menu.ImageIndex := 59
                else
                  begin
                    // On recupere l icone de la dll
                    Icon := TIcon.Create;
                    Icon.Handle := ExtractIcon(Mot, Pchar(_Path_Appli + _REL_PATH_PLUGINS + S.Strings[i]), 0);
 
                    nIco := dm.ImageListMenu.AddIcon(Icon);
 
                    if nIco = -1 then
                      Menu.ImageIndex := 59
                    else
                      Menu.ImageIndex := nIco;
 
                    FreeAndNil(Icon);
                  end;
              end
            else
              ShowMessage('Erreur pendant le chargement de la dll : ' + _Path_Appli + _REL_PATH_PLUGINS + S.Strings[i]);
          except
            ShowMessage('Erreur pendant le chargement de la dll : ' + _Path_Appli + _REL_PATH_PLUGINS + S.Strings[i]);
          end;
 
          FreeLibrary(HAddOn);
 
          Application.ProcessMessages;
        end;
      LockUpdate := False;
    end;
 
  FreeAndNil(s);
end;

el la suite ici

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
procedure TFMain.OnClickDll(sender: TObject);
 
type
  tProcedure = procedure(sBase: pChar; Haut, Largeur: integer);
  tRetourDll = function: PInteger;
  TSkinDll = procedure(ahandle: HWnd; adata: Pointer);
  // Ici on ouvre la fonction principale de la dll ----------
var
  HAddOn: LongWord;
  s_Query: TIBQuery;
  iRetourDll: PInteger;
  i: Integer;
  SetApp: Tskindll;
  ShowFrm: tProcedure;
 
begin
  _FOccupe.doActive;
 
  Screen.Cursor := crHourglass;
 
  doCloseFenetresFlottantes;
 
  Application.ProcessMessages;
 
  iRetourDll := 0;
  HAddOn := 0;
 
  // on verifie qu on est bien sur une bonne fiche ---------------------------------------------------------
  s_Query := TIBQuery.Create(Application);
 
  with s_Query do
    begin
      DataBase := dm.ibd_BASE;
      SQL.Clear;
      SQL.ADD('SELECT * FROM PROC_GESTION_DLL');
      Open;
      i := FieldByName('CLE_FICHE').AsInteger;
      Close;
      FreeAndNil(s_Query);
    end;
 
  // si on est pas sur une fiche, on sort -------------------
  if (i < 1) or (dm.ficheActive < 1) then
    begin
      ShowMessage('Vous devez d''abord sélectionner un individu....');
      exit;
    end;
  //--------------------------------------------------------------------------------------------------------
 
  bfsbQuitter.Enabled := False;
  bfsbRecherche.Enabled := False;
  Quitter1.Enabled := False;
 
  FMAin.Enabled := False;
 
  dm.DoUpdateDLL;
  // -- Ouverture de la dll --------------------------------------------------------------------------------
  if sender.ClassType = TLabel then
    begin
      if (sender as TLabel).Tag = 999 then
        HAddOn := LoadLibrary(pchar(_Path_Appli + _REL_PATH_PLUGINS + (sender as TLabel).Hint))
      else if (sender as TLabel).Tag = 998 then
        begin
          HAddOn := LoadLibrary(pchar(_Path_Appli + _REL_PATH_PLUGINS + (sender as TLabel).Hint));
        end;
    end
 
  else
    HAddOn := LoadLibrary(pchar(_Path_Appli + _REL_PATH_PLUGINS + (sender as TdxBarButton).Description));
 
  // -- si l ouverture se passe bien -----------------------------------------------------------------------
  if HAddOn <> 0 then
    begin
      _FOccupe.doDesactive;
      Application.ProcessMessages;
      try
        @showFrm := GetProcAddress(HAddOn, 'InitStartDll');
        @setApp := GetProcAddress(HAddOn, 'SetApplicationHandle');
 
        if @showFrm <> nil then
          showfrm(pChar(_Context.PathFileNameBdd), Height - 80, Width - 20);
 
        // La dll est fermée et on recupere le retour de la dll, grace a une methode de la dll
        try
          iRetourDll := TRetourDll(GetProcAddress(HAddOn, 'RetourDll'));
        except
          //iRetourDll := PInteger(-10);
        end;
 
        if iRetourDll = PInteger(-10) then
          dm.doCloseDatabase; //fermeture de la connexion
 
        @setApp := nil;
        @showFrm := nil;
 
        if HaddOn <> 0 then
          freeLibrary(HaddOn);
        HaddOn := 0;
        Screen.Cursor := crDefault;
 
      except
        showmessage('Erreur d''exécution de la dll');
        if HaddOn <> 0 then
          freeLibrary(HaddOn);
      end;
 
    end;
 
  try
    if not dm.ibd_BASE.Connected then
      begin
        dm.doOpenDatabase;
        if CloseModuleActif then
          OpenModule(_ID_INDIVIDU);
      end;
  except
    //showmessage('non');
  end;
 
  Application.ProcessMessages;
 
  bfsbRecherche.Enabled := True;
 
  FMAin.Enabled := True;
 
  Quitter1.Enabled := True;
  bfsbQuitter.Enabled := True;
 
  Application.ProcessMessages;
 
  Screen.Cursor := crDefault;
 
end;

**LeGEC** · 05/12/2008, 09h45

Salut,

Pourrais-tu préciser où a lieu la violation?

*LeGEC*

**anapurna** · 05/12/2008, 10h31

salut

le message d'erreur afin qu'il puisse nous indiquez si par hasard tu n' essai pas d'accéder a un composant non instancié

@+ Phil

**ShaiLeTroll** · 05/12/2008, 10h35

Pourquoi autant de Application.ProcessMessages ? ton traitement est-il si long ? Tu n'as même pas de barre de progression, la création de MenuItem n'as pas besoin de cela pour fonctionner non plus ! C'est encore moins utile en fin de fonction, il faut l'utiliser avec parcimonie, c'est à croire que personne ne sait vrai à quoi sert Application.ProcessMessages, tout le monde en mets partout à toute les sauces ...

quelques simplifications évidentes :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 if sender.ClassType = TLabel then

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if Sender is TLabel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if upperCase(S.Strings[i]) = upperCase('DLLCreationWeb.dll') then

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if SameText(S.Strings[i], 'DLLCreationWeb.dll') then

le FreeAndNil sur des variables locales est inutile !
ajouter des Try Finally de la forme

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Obj := TClass.Create();
try
  ...
finally
  Obj.Free();
end;

Enfin, coche dans les options du débuggeur, dans l'onglet des exceptions, la case "Arrêter sur Exception Delphi"

**ZZZzzz2** · 05/12/2008, 12h36

Envoyé par ShaiLeTroll

Pourquoi autant de Application.ProcessMessages ? ton traitement est-il si long ? Tu n'as même pas de barre de progression, la création de MenuItem n'as pas besoin de cela pour fonctionner non plus ! C'est encore moins utile en fin de fonction, il faut l'utiliser avec parcimonie, c'est à croire que personne ne sait vrai à quoi sert Application.ProcessMessages, tout le monde en mets partout à toute les sauces ...

quelques simplifications évidentes :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 if sender.ClassType = TLabel then

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if Sender is TLabel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if upperCase(S.Strings[i]) = upperCase('DLLCreationWeb.dll') then

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

if SameText(S.Strings[i], 'DLLCreationWeb.dll') then

le FreeAndNil sur des variables locales est inutile !
ajouter des Try Finally de la forme

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Obj := TClass.Create();
try
  ...
finally
  Obj.Free();
end;

Enfin, coche dans les options du débuggeur, dans l'onglet des exceptions, la case "Arrêter sur Exception Delphi"

"ProcessMessages" c'est un nid à emmerdes quand c'est utilisé n'importe comment...
Retires-les tous, quitte à ce que ton application donne l'air d'avoir figé (tant que ce n'est pas réellement le cas) et regarde si tu as toujours des violations d'accès, après (et si cela corrige le problème) seulement tu pourras voir comment remplacer tes appels à ProcessMessages.

**Cazaux-Moutou-Philippe** · 05/12/2008, 12h36

Merci

je vais essayer ca de suite

**Cazaux-Moutou-Philippe** · 05/12/2008, 12h47

Mais depuis ce matin j ei des erreurs interne C13310
et je ne sais pas comment regler ca

voir ici

http://www.developpez.net/forums/d65...nterne-c13310/

Ce code provoque des violations

Langage Delphi

Discussions similaires

Partager

Partager