Programmer 7500/MAX_PROGRAMMERS.iso/TURBO_P/TPWFORT.ZIP/CHCASTPW.PAS

Pascal/Delphi Source File | 1992-06-11 | 11.6 KB | 427 lines

{************************************************}
{                                                }
{   Turbo Pascal for Windows                     }
{   Demo program using MS FORTRAN 5.1 DLL        }
{   August Miller -> internet: [e-mail]   }
{                                                }
{************************************************}

(*
   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.