home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Windoware
/
WINDOWARE_1_6.iso
/
source
/
tpwfort
/
chcastpw.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-06-11
|
12KB
|
427 lines
{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Demo program using MS FORTRAN 5.1 DLL }
{ August Miller -> internet: miller@nmsu.edu }
{ }
{************************************************}
(*
This program is that of a really novice Windows and Pascal
programmer. Most of it was pirated in some form or other from
the demo programs supplied with Turbo Pascal foe Windows 1.0.
Borland certainly wasn't responsible for any stupid constructions
that you might find here, however. . they are mine alone!
I started this when I found that I was pretty disappointed with
the "Quick Win" interface provided by Microsoft's FORTRAN 5.1 and
wondered if I might be able to use Turbo Pascal to call up a program
written in FORTRAN. This program is just a shell and
does nothing but read an input file, convert all the characters
to upper case, and them write the results to ANOTHER file..
There are slicker ways to do that. This was just an experiment,
but may be of interest to one or two other people.
I began with a FORTRAN subroutine named CHCASW.FOR to which we must
pass the names of the input and output files as well as an integer
parameter which specifies whether conversion is to UPPER or lower
case. CHCASW.FOR was compiled and linked into a DLL called CHCASW.DLL
The internal (actual) name in the subroutine header is CHCASE. CHCASE
opens the input and output files, does its job and then closes both
files. (I did it that way because I didn't have the slightest idea as
to how to open them in Turbo Pascal and then pass the proper
logical unit numbers to the FORTRAN subroutine.)
This TP program to solicit names for input and output files and
to call the CHCASE subroutine in CHCASW.DLL to do the converting and
file handling. CHCASW.DLL and should be put in your base Windows
directory before you run this one.
There is an interface program CHCASW.PAS which you must compile
to produce CHCASW.TPU before compiling this one. The interface
program is the guts of setting up calls to a FORTRAN dll.. you
gotta make all the variable types are consistent for both worlds.
Finally, there is CHCASW.RES which contains a menu of sorts:
The "File" item has two sub items which are used to enter the input
and output file names. The "Run" item brings up the actual call of
the subroutine "CHCASE.FOR" which is all that is in CHCASW.DLL.
Nothing at all appears in the program's main window except the
file dialog boxes.
The FORTRAN related files are:
CHCASW.FOR - the source code for the "change case" routine.
CHCASW.DEF - "definition" file needed to create the DLL.
CHCASDLL.MAK - the "NMAKE" file to create CHCASW.DLL.
*)
program MyProgram;
uses Strings, WinTypes, WinProcs, WinDos, WObjects, StdDlgs,chcasw;
{$R chcasw.res}
const
cm_new = 101;
cm_Open = 102; {open IOIN file!!}
cm_save = 103;
cm_SaveAs = 104; {open/create IOUT file}
cm_Help = 901;
idm_go = 200;
cm_myexit = 300;
var
FileName: fnam ;
ioinname,ioutname: fnam; {var type is defined in chcasw.pas}
auxflag, IsDirty, IsNewFile: Boolean;
itype,ierr,iochek,forgetit: integer;
inok,outok,oktogo: boolean;
mystring: string;
type
TMyApplication = object(TApplication)
procedure InitMainWindow; virtual;
end;
type
PMyWindow = ^TMyWindow;
TMyWindow = object(TWindow)
constructor Init(AParent: PWindowsObject; ATitle: PChar);
destructor Done; virtual;
procedure GO(var Msg: Tmessage); virtual cm_First+idm_Go;
function CanClose: Boolean; virtual;
procedure FileNew(var Msg: TMessage);
virtual cm_First + cm_New;
procedure FileOpen(var Msg: TMessage);
virtual cm_First + cm_Open;
procedure FileSave(var Msg: TMessage);
virtual cm_First + cm_Save;
procedure FileSaveAs(var Msg: TMessage);
virtual cm_First + cm_SaveAs;
function Nexistq:boolean;
function Fexistq:boolean;
procedure Help(var Msg: TMessage);
virtual cm_First + cm_Help;
procedure alldone(var Msg: Tmessage); virtual cm_First+cm_myexit;
end;
{--------------------------------------------------}
{ TMyWindow's method implementations: }
{--------------------------------------------------}
constructor TMyWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
TWindow.Init(AParent, ATitle);
Attr.Menu := LoadMenu(HInstance,'menu_1');
inok := false;
outok := false;
oktogo := false;
ierr := 0;
while ierr < 64 do
begin
ioinname[ierr] := ' ';
ioutname[ierr] := ' ';
inc(ierr)
end;
end;
{ -------------------------------------------------------------- }
destructor TMyWindow.Done;
begin
TWindow.Done;
end;
{ -------------------------------------------------------------- }
procedure TMyWindow.alldone(var Msg: TMessage);
begin
if (canclose) then TMyWINDOW.DONE
end;
{ -------------------------------------------------------------- }
function tMYwindow.FEXISTQ: BOOLEAN;
{ *** checks to see if file exists *** }
{the file name is passed in global variable "filename" }
var
filstr: array[0..fsPathName] of Char;
filnam: string;
tempstr: array [0..48] of Char;
label endit;
begin
filnam := strpas(filename);
filesearch(filstr,filename,GetENvVar('PATH'));
if (filstr[0] <> #0) then
auxflag := true
else
auxflag := false;
if (auxflag) then {the file DOES EXIST! }
begin
fexistq := true;
TEMPSTR[0] := #0; {there is probably a much slicker way to}
strcat(tempstr,''); {get the tempstr array put togetger}
strcat(tempstr,'Destroy file: ');
strcat(tempstr,filename);
strcat(tempstr,' ?');
{not real slick...just aborts on NO.Doesn't ask for new fname}
forgetit := MessageBox(Hwindow,tempstr,
'* File Already Exists! *',MB_YESNOCANCEL+mb_ICONQUESTION);
if (forgetit = id_yes) then
begin
auxflag := false; {or lie and say that it doesn't}
goto endit;
end;
if (forgetit = id_cancel) or (forgetit = id_no) then
begin
auxflag := true;
goto endit;
end;
end; {of if forgetit = id_ok ?}
endit:
fexistq := auxflag;
end;
{ -------------------------------------------------------------- }
{ -------------------------------------------------------------- }
function tMYwindow.NEXISTQ: BOOLEAN;
{ *** checks to see if file exists *** }
{the file name is passed in global variable "filename" }
var
filstr: array[0..fsPathName] of Char;
filnam: string;
tempstr: array [0..48] of Char;
label endit;
begin
filnam := strpas(filename);
filesearch(filstr,filename,GetENvVar('PATH'));
if (filstr[0] <> #0) then
nexistq := true
else
begin
nexistq := false;
end;
end;
{ -------------------------------------------------------------- }
function TMyWindow.CanClose: Boolean;
var
Reply: Integer;
begin
CanClose := True;
(*
Reply := MessageBox(HWindow, 'Do you want to save?',
'Drawing has changed', mb_YesNo or mb_IconQuestion);
if Reply = id_Yes then CanClose := False;
*)
end;
{ -------------------------------------------------------------- }
procedure TMyWindow.FileNew(var Msg: TMessage);
begin
(* Just a dummy .. copied from BORLAND demo *)
end;
{ -------------------------------------------------------------- }
procedure TMyWindow.FileOpen(var Msg: TMessage);
var
areply: integer;
begin
areply := Application^.ExecDialog(New(PFileDialog,
Init(@Self, PChar(sd_FileOpen), StrCopy(ioinname, '*.*'))));
filename := ioinname;
if (nexistq) then
inok := true
else
begin
messagebox(Hwindow,
'Can not find that file. Please choose another one.',
ioinname,mb_ok);
inok := false;
end;
end;
{ -------------------------------------------------------------- }
procedure TMyWindow.FileSave(var Msg: TMessage);
begin
MessageBox(HWindow, 'Feature not implemented', 'FileSave', mb_Ok);
end;
{ -------------------------------------------------------------- }
procedure savefile;
begin
(*
assign(iouttx,filename);
rewrite(iouttx); {unconditional file open.erases existing file}
*)
(* In this application, the FORTRAN DLL will actually do the writing
so all we want to do here is to OPEN THE FILE with KNOWN ID IOUT
*)
(*
Points^.ForEach(@writit); {save everything in the POINTS stucture}
close(iout); {close the output file}
isdirty := false;
*)
end;
{ ------------------------------------------------------------- }
procedure tmYwindow.FileSaveAs(var Msg: TMessage);
var
FileDlg: PFileDialog;
reply,areply: integer;
auxflag: boolean;
label abegin;
begin
abegin:
StrCopy(IoutName, '');
reply := Application^.ExecDialog(New(PFileDialog,
Init(@Self, PChar(sd_FileSave), IoutName)));
filename :=ioutname;
if (reply = id_Ok) then
begin
auxflag := fexistq;
if not(auxflag) then
begin
outok := true;
SaveFile;
end;
if (auxflag) then
begin
if (forgetit <> id_cancel) then
goto abegin; {ask for another name}
end;
end;
end;
{ -------------------------------------------------------------- }
procedure TMyWIndow.GO(Var MSg: Tmessage);
(* THIS ROUTINE IS THE ONE WHICH ACTUALLY CALLS THE FORTRAN ROUTINE *)
begin
if ( (inok) and (outok) ) then
begin
oktogo := true;
itype := 1;
(* now call the FORTRAN subroutine CHCASE compiled into CHCASW.DLL *)
chcase(IOINNAME,IOUTNAME,itype,ierr,iochek) ;
(* check error flags returned by CHCASE *)
if ierr = 0 then
messagebox(Hwindow,'CHCASE run was successful. ','* CHCASE *',mb_ok);
if ierr <> 0 then
begin
str(iochek:5,mystring); {reconvert to fixed str}
mystring :='CHCASE: IOCHECK = '+mystring;
MessageBox(HWindow,@mystring[1], ioinName, mb_ok);
end;
end;
if not(oktogo) then
begin
if not(inok) then
messagebox(Hwindow,'No input file yet chosen!',' ??? ', mb_ok);
if not(outok) then
messagebox(Hwindow,'No output file yet chosen!',' ??? ',mb_ok);
end;
(* reset run check flags *)
if (oktogo) then
begin
oktogo := false;
inok := false;
outok := false;
end;
end;
{ -------------------------------------------------------------- }
procedure TMyWindow.Help(var Msg: TMessage);
var
HelpWnd: PWindow;
begin
(*
HelpWnd := New(PWindow, Init(@Self, 'Help System'));
with HelpWnd^.Attr do
begin
Style := Style or ws_Visible or ws_PopupWindow or ws_Caption;
X := 100;
Y := 100;
W := 300;
H := 300;
end;
Application^.MakeWindow(HelpWnd);
*)
end;
{--------------------------------------------------}
{ TMyApplication's method implementations: }
{--------------------------------------------------}
procedure TMyApplication.InitMainWindow;
begin
MainWindow := New(PMyWindow, Init(nil, 'Sample ObjectWindows Program'));
end;
{--------------------------------------------------}
{ Main program: }
{--------------------------------------------------}
var
MyApp : TMyApplication;
begin
MyApp.Init('MyProgram');
MyApp.Run;
MyApp.Done;
end.