Greshnick
21-07-2013, 19:36
Доброго времени суток, уважаемые форумчане. Вопрос по поводу создания не модальных окон в делфи. В приложение при закрытии которого происходит сбой. Т.е. программа вызывает из dll библиотеки немодальное окно там пользователь совершает манипуляции и выходит из него. И если мы закрываем наше приложение, то выскакивает сообщение винды о сбое и в диспетчере задач остается в памяти процесс приложения и идет загруз ЦП на 50-60 процентов Уже все перепробовал даже не знаю что может быть.
Исходный код exe файла:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, ShockwaveFlashObjects_TLB, ExtCtrls, StdCtrls, ShellApi,
AppEvnts, Menus, XPMan;
function ADDBASE(Handle: THandle; connect: string):LongInt;stdcall;
procedure FREEBASE(RefForm: LongInt);export;stdcall
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
ShockwaveFlash1: TShockwaveFlash;
ComboBox1: TComboBox;
XPManifest1: TXPManifest;
Label1: TLabel;
ShockwaveFlash2: TShockwaveFlash;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
function PoiskBD : TStringList;
procedure ComboBox1Enter(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ShockwaveFlash2FSCommand(ASender: TObject; const command,
args: WideString);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
f : LongInt;
function ADDBASE; external 'source1\add\bibl\Project1.dll';
procedure FREEBASE;external 'source1\add\bibl\Project1.dll';
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var R1 : HRGN;
begin
R1:= CreateRoundRectRgn(0, 0, Width-1, Height-1,40, 40);
SetWindowRgn(Handle, R1, True);
form1.Color:=$00999966;
ShockwaveFlash1.Movie := ExtractFilePath(Application.ExeName) + '1.swf';
ShockwaveFlash2.Movie := ExtractFilePath(Application.ExeName) + 'source1\add\bibl\1.swf';
end;
procedure TForm1.ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
begin
if command = 'Click' then Form1.Close;
end;
function TForm1.PoiskBD: TStringList;
var
searchResult : TSearchRec;
Find: String;
Begin
Find:=ExtractFileDir(Application.ExeName)+'\base\*.xml';
Result:=TStringList.Create;
if FindFirst(Find, faAnyFile, searchResult) = 0 then
begin
repeat
Result.Add(searchResult.Name);
until FindNext(searchResult) <> 0;
FindClose(searchResult);
end;
end;
procedure TForm1.ComboBox1Enter(Sender: TObject);
begin
Form1.ComboBox1.Items:=Form1.PoiskBD;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
ShockwaveFlash1.CallFunction('<invoke name="myFunction" returntype="xml"><arguments><string>base\'+Form1.ComboBox1.Text+'</string></arguments></invoke>');
end;
procedure TForm1.ShockwaveFlash2FSCommand(ASender: TObject; const command,
args: WideString);
begin
if command='exit' then Form1.Close;
if command='add' then Begin
end;
if command='delete' then ShowMessage('Óäàëèòü');
if command='replace' then ShowMessage('Èçìåíèòü');
if command='new' then ShowMessage('Ñîçäàòü');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if f>0 then
FREEBASE(f);
f:=ADDBASE(Application.Handle, ExtractFilePath(Application.ExeName)+'base\'+Form1.ComboBox1.Text);
end;
end.
Исходный код окна в dll библиотеки
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls, OleCtrls, ShockwaveFlashObjects_TLB,xmldom, XMLIntf, msxmldom, XMLDoc,
AppEvnts;
type
TForm1 = class(TForm)
Image1: TImage;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Label3: TLabel;
Edit3: TEdit;
Button1: TButton;
Label4: TLabel;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
ShockwaveFlash1: TShockwaveFlash;
ApplicationEvents1: TApplicationEvents;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ADD;
procedure FormActivate(Sender: TObject);
procedure ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
procedure ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
private
{ Private declarations }
procedure WMNCHitTest(var Message: TWMNCHitTest);message WM_NCHITTEST;
public
{ Public declarations }
end;
var
Form1: TForm1;
Base : String;
function ADDBASE(Handle: THandle; connect: string):LongInt;export;stdcall;
procedure FREEBASE(RefForm : LongInt); export; stdcall;
implementation
{$R *.dfm}
function ADDBASE(Handle: THandle; connect : string): LongInt;
Begin
Application.Handle:=Handle;
Form1:=TForm1.Create(Application);
Result:=LongInt(Form1);
Base:=connect;
Form1.Show;
end;
procedure FREEBASE(RefForm: LongInt);
Begin
if RefForm>0 then TForm1(RefForm).Release;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
R1: HRgn;
begin
R1:= CreateRoundRectRgn(0, 0, Width-1, Height-1,40, 40);
SetWindowRgn(Handle, R1, True);
end;
procedure TForm1.Add;
var Xml: IXMLDocument;
Summ : integer;
begin
xml:=TXMLDocument.Create(nil);
xml.LoadFromFile(Base);
xml.Active:=True;
Summ:=xml.DocumentElement.ChildNodes.Count+1;
with xml.ChildNodes['images'].AddChild('image') do
Begin
Attributes['id']:=IntToStr(Summ);
ChildValues ['title'] := Edit1.Text;
ChildValues['names']:=Edit2.Text;
ChildValues['img']:=Edit3.Text;
ChildValues['opis']:=Memo1.Text;
end;
xml.SaveToFile(Base);
xml.Active:=False;
Edit1.Text:='';
Edit2.Text:='';
Edit3.Text:='';
Memo1.Text:='';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Form1.OpenDialog1.Execute=true then Edit3.Text:=Form1.OpenDialog1.FileName;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
Form1.ShockwaveFlash1.Movie:=ExtractFilePath(Application.ExeName)+'source1\add\bibl\1.swf';
end;
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
Message.Result := HTCAPTION;
end;
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
if msg.message = WM_RBUTTONDOWN then
Handled := True;
end;
procedure TForm1.ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
begin
if command='add' then ADD;
if command='exit' then Form1.Close;
end;
end.
И код самой библиотеки:
library Project1;
uses
SysUtils,
Classes,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
exports
ADDBASE,
FREEBASE;
begin
end.
Помогите, в чем может быть проблема и как ее исправить.
Исходный код exe файла:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, ShockwaveFlashObjects_TLB, ExtCtrls, StdCtrls, ShellApi,
AppEvnts, Menus, XPMan;
function ADDBASE(Handle: THandle; connect: string):LongInt;stdcall;
procedure FREEBASE(RefForm: LongInt);export;stdcall
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
ShockwaveFlash1: TShockwaveFlash;
ComboBox1: TComboBox;
XPManifest1: TXPManifest;
Label1: TLabel;
ShockwaveFlash2: TShockwaveFlash;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
function PoiskBD : TStringList;
procedure ComboBox1Enter(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ShockwaveFlash2FSCommand(ASender: TObject; const command,
args: WideString);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
f : LongInt;
function ADDBASE; external 'source1\add\bibl\Project1.dll';
procedure FREEBASE;external 'source1\add\bibl\Project1.dll';
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var R1 : HRGN;
begin
R1:= CreateRoundRectRgn(0, 0, Width-1, Height-1,40, 40);
SetWindowRgn(Handle, R1, True);
form1.Color:=$00999966;
ShockwaveFlash1.Movie := ExtractFilePath(Application.ExeName) + '1.swf';
ShockwaveFlash2.Movie := ExtractFilePath(Application.ExeName) + 'source1\add\bibl\1.swf';
end;
procedure TForm1.ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
begin
if command = 'Click' then Form1.Close;
end;
function TForm1.PoiskBD: TStringList;
var
searchResult : TSearchRec;
Find: String;
Begin
Find:=ExtractFileDir(Application.ExeName)+'\base\*.xml';
Result:=TStringList.Create;
if FindFirst(Find, faAnyFile, searchResult) = 0 then
begin
repeat
Result.Add(searchResult.Name);
until FindNext(searchResult) <> 0;
FindClose(searchResult);
end;
end;
procedure TForm1.ComboBox1Enter(Sender: TObject);
begin
Form1.ComboBox1.Items:=Form1.PoiskBD;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
ShockwaveFlash1.CallFunction('<invoke name="myFunction" returntype="xml"><arguments><string>base\'+Form1.ComboBox1.Text+'</string></arguments></invoke>');
end;
procedure TForm1.ShockwaveFlash2FSCommand(ASender: TObject; const command,
args: WideString);
begin
if command='exit' then Form1.Close;
if command='add' then Begin
end;
if command='delete' then ShowMessage('Óäàëèòü');
if command='replace' then ShowMessage('Èçìåíèòü');
if command='new' then ShowMessage('Ñîçäàòü');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if f>0 then
FREEBASE(f);
f:=ADDBASE(Application.Handle, ExtractFilePath(Application.ExeName)+'base\'+Form1.ComboBox1.Text);
end;
end.
Исходный код окна в dll библиотеки
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls, OleCtrls, ShockwaveFlashObjects_TLB,xmldom, XMLIntf, msxmldom, XMLDoc,
AppEvnts;
type
TForm1 = class(TForm)
Image1: TImage;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Label3: TLabel;
Edit3: TEdit;
Button1: TButton;
Label4: TLabel;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
ShockwaveFlash1: TShockwaveFlash;
ApplicationEvents1: TApplicationEvents;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ADD;
procedure FormActivate(Sender: TObject);
procedure ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
procedure ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
private
{ Private declarations }
procedure WMNCHitTest(var Message: TWMNCHitTest);message WM_NCHITTEST;
public
{ Public declarations }
end;
var
Form1: TForm1;
Base : String;
function ADDBASE(Handle: THandle; connect: string):LongInt;export;stdcall;
procedure FREEBASE(RefForm : LongInt); export; stdcall;
implementation
{$R *.dfm}
function ADDBASE(Handle: THandle; connect : string): LongInt;
Begin
Application.Handle:=Handle;
Form1:=TForm1.Create(Application);
Result:=LongInt(Form1);
Base:=connect;
Form1.Show;
end;
procedure FREEBASE(RefForm: LongInt);
Begin
if RefForm>0 then TForm1(RefForm).Release;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
R1: HRgn;
begin
R1:= CreateRoundRectRgn(0, 0, Width-1, Height-1,40, 40);
SetWindowRgn(Handle, R1, True);
end;
procedure TForm1.Add;
var Xml: IXMLDocument;
Summ : integer;
begin
xml:=TXMLDocument.Create(nil);
xml.LoadFromFile(Base);
xml.Active:=True;
Summ:=xml.DocumentElement.ChildNodes.Count+1;
with xml.ChildNodes['images'].AddChild('image') do
Begin
Attributes['id']:=IntToStr(Summ);
ChildValues ['title'] := Edit1.Text;
ChildValues['names']:=Edit2.Text;
ChildValues['img']:=Edit3.Text;
ChildValues['opis']:=Memo1.Text;
end;
xml.SaveToFile(Base);
xml.Active:=False;
Edit1.Text:='';
Edit2.Text:='';
Edit3.Text:='';
Memo1.Text:='';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Form1.OpenDialog1.Execute=true then Edit3.Text:=Form1.OpenDialog1.FileName;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
Form1.ShockwaveFlash1.Movie:=ExtractFilePath(Application.ExeName)+'source1\add\bibl\1.swf';
end;
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
Message.Result := HTCAPTION;
end;
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
if msg.message = WM_RBUTTONDOWN then
Handled := True;
end;
procedure TForm1.ShockwaveFlash1FSCommand(ASender: TObject; const command,
args: WideString);
begin
if command='add' then ADD;
if command='exit' then Form1.Close;
end;
end.
И код самой библиотеки:
library Project1;
uses
SysUtils,
Classes,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
exports
ADDBASE,
FREEBASE;
begin
end.
Помогите, в чем может быть проблема и как ее исправить.