Power-Programmierung/CD1.mdf/fortran/mslang/avi/testavi.for

Text File | 1994-04-12 | 5.3 KB | 135 lines

C     Totally FORTRAN implementation of EQUIPMENT_ENTRY
C     by Barry W. McCleave, PhD, P.E. 601-634-2599
C      FORM TEMPLATE
c      itemtype()=I means integer*2             Int
c      itemtype()=L (or l) means integer*4      Longint
c      itemtype()=R (or r) means real*4         Real
c      itemtype()=D (or d )means real*8         Double Precision
c      itemtype()=C (or c) means string         Characters (termination \)
c      itemtype()=S (or s) choice only          Selection
c      itemtype()=T (or t) comment field        Text
c      itemtype()=H (or h) form title           Heading
c      itemchosen()= the list item selected (0 if edit entry)
c      delimeter=^ after each selection list item; before first list item
c      delimeter=| at end of every form item
c      delimeter=\ at end of every text line (\\ produces \ if c string)
c      last item followed by 0 (\0 poduces 0 if c string)
      include 'configur.fi'
      integer*4 function WinMain [stdcall,alias:'_WinMain@16']
     1 (hInstance[VALUE],
     1 hPrevInstance[VALUE],lpszCmdLine[VALUE], nCmdShow[VALUE])
      include 'configur.fd'
      logical*1 form
      integer*4 hinstance,hprevinstance
      integer*4 lpszcmdline
      integer*4 ncmdshow
      integer*4 initmain
      integer*4 hwnd
      Character*80 a
      Character*42 Filein
      Character*97 Exitform
      CHARACTER*30 FILEEQUI,FILEN
      LOGICAL*1 EXITFLAG
      INTEGER*4 INFILEPTR
      real*8 infrows(1),exitrows(1)
      integer*1 itemchin(1),itemchexit(1)
      EQUIVALENCE (INFROWS(1),INFILEPTR)
      DATA  ITEMCHIN/0/,ITEMCHEXIT/1/,EXITFLAG/.FALSE./
      DATA FILEEQUI/'\0'C/,FILEN/'\0'C/,FILEO/'\0'C/
      DATA FILEIN/'CAVI FILE NAME LESS EXTENSION^Quit NOW ^|\0'c/
      DATA EXITFORM /'SNEXT ACTION     ^EXIT PROGRAM^BACKUP ONE FORM^RET
     1URN TO CURRENT FORM^|hOOPS! Chose Next Action|\0'c/
      winmain=0
      if(initmain(hinstance,hprevinstance,ncmdshow,hwnd).ne.TRUE) Return
      INFILEPTR=LOCFAR(FILEN)
9001  EXITFLAG=.FALSE.
       IF(FORM(hinstance,hWnd,FILEIN,ITEMCHIN,INFROWS)) THEN
          IF (ITEMCHIN(1).EQ.0) THEN
C            READ IN FILE
             fileo=filen
             CALL GET_NAME_OF_FILE(FILEN,FILEEQUI,NUMCHAR)
          ELSE
             ITEMCHEXIT(1)=1
             EXITFLAG=.TRUE.
             IF(FORM(hinstance,hWnd,EXITFORM,ITEMCHEXIT,exitrows)) THEN
             endif
          ENDIF
       ENDIF
       IF(EXITFLAG.AND.ITEMCHEXIT(1).EQ.1) GOTO 9999
       IF(EXITFLAG.AND.ITEMCHEXIT(1).EQ.2) GOTO 9999
       IF(EXITFLAG.AND.ITEMCHEXIT(1).EQ.3) GOTO 9001
       write(a,23,err=9999) 'open ',fileequi(1:numchar+3),
     1  ' alias test\0'c
 23    format(a5,a30,a12)
       ierr=mciSendString(locfar(a),NULL,0,NULL)
       write(a,24,err=9999) 'window test handle',hwnd,'\0'c
 24    format(a18,i12,a1)
       ierr=mciSendString(locfar(a),NULL,0,NULL)
       ierr=mciSendString(locfar('play test wait\0'c),Null,0,Null)
       ierr=mciSendString(locfar('close test\0'c),Null,0,Null)
9999   WinMain=0
      return
      end

      SUBROUTINE GET_NAME_OF_FILE(BUF,FILEEQUIPMENT,NUMCHAR)
      CHARACTER*30 FILEEQUIPMENT,BUF
      character*1 term
      PARAMETER (term=0)
      NUMCHAR=1
      DO WHILE (NUMCHAR.le.30.and.BUF(NUMCHAR:NUMCHAR).ne.term)
            NUMCHAR=NUMCHAR+1
      END DO
      DO J=1,30
         IF (J.LE.Numchar-1) THEN
            FILEEQUIPMENT(J:J)=BUF(J:J)
         ELSE
            IF (J.EQ.Numchar) THEN
               FILEEQUIPMENT(J:J)='.'
            ELSE IF (J.EQ.Numchar+1) THEN
               FILEEQUIPMENT(J:J)='A'
            ELSE IF (J.EQ.Numchar+2) THEN
               FILEEQUIPMENT(J:J)='V'
            ELSE IF (J.EQ.Numchar+3) THEN
               FILEEQUIPMENT(J:J)='I'
            ELSE
               FILEEQUIPMENT(J:J)=' '
            ENDIF
         ENDIF
      END DO
      RETURN
      END

       integer*4 Function Initmain(
     1 hInstance,hPrevInstance,ncmdshow,hwnd)
       include 'testproc.fd'
       external defwindowproc
       integer*4 hInstance,hPrevInstance,nCmdShow
       integer*4 createwindowex,loadcursor,registerclass
      record /wndclass/ windowclass
        integer*4   hWnd
c       integer*4 idc_arrow
c       data idc_arrow/32512/
      Initmain = TRUE
c     if no previous instance of the application fill in WNDCLASS
      if (hPrevInstance.eq.false) then
         WindowClass.lpszClassName = locfar('MainWin'C)
         WindowClass.hInstance     = hInstance
         WindowClass.lpfnWndProc   = locfar(Defwindowproc)
         WindowClass.hCursor       = LoadCursor(null,idc_arrow)
         WindowClass.hIcon         = NULL
         WindowClass.lpszMenuName  = NULL
         WindowClass.hbrBackground = COLOR_WINDOW + 1
         WindowClass.style         = 0
         WindowClass.cbClsExtra    = 0
         WindowClass.cbWndExtra    = 0
         if (RegisterClass (WindowClass).eq.false) Initmain = false
      end if
c     Register the class
      hWnd = CreateWindowex(0,locfar('MainWin'C),locfar('MAIN'C),
     1 WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,0,CW_USEDEFAULT,0,NULL,
     1 NULL,hInstance,NULL)
c     show the window as it is not visible by default
      call ShowWindow (hWnd,nCmdShow)
      return
      end