home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / mslang / avi / form32.for < prev    next >
Encoding:
Text File  |  1994-02-08  |  30.2 KB  |  776 lines
  1. C     Totally FORTRAN implementation of forms
  2. C     by Barry W. McCleave, PhD, P.E. 601-634-2599
  3.       include 'form32.fi'      
  4.       Logical*1 Function FORM (hInstance,
  5.      1 hwndmain,formtext1,itemselected,valueitem)      
  6. C      FORM TEMPLATE
  7. c      itemtype()=B means row of action buttons Button
  8. c      itemtype()=I means integer*2             Int
  9. c      itemtype()=L (or l) means integer*4      Longint
  10. c      itemtype()=R (or r) means real*4         Real
  11. c      itemtype()=D (or d )means real*8         Double Precision
  12. c      itemtype()=C (or c) means string         Characters (termination \)
  13. c      itemtype()=S (or s) choice only          Selection
  14. c      itemtype()=T (or t) comment field        Text
  15. c      itemtype()=H (or h) form title           Heading
  16. c      itemchosen()= the list item selected (0 if edit entry)
  17. c      delimeter=^ after each selection list item; before first list item 
  18. c      delimeter=| at end of every form item
  19. c      delimeter=\ at end of every text line (\\ produces \ if c string)
  20. c      last item followed by 0 (\0 poduces 0 if c string)
  21. c
  22.       include 'form32.fd'
  23.       character*1 term
  24.       parameter (term=0)
  25.       Integer*4 msgloop
  26.       integer*1 itemselected(1)
  27.       real*8 valueitem(1)
  28.       integer*1 item(20)
  29.       logical*1 confirm
  30.       real*8 value(20)
  31.       Integer*4 hinstance,init
  32.       Character*80 TextBuffer 
  33.       character*2000 formtext
  34.       character*(*) formtext1
  35.       integer*1 formt(2000),base_small_letters
  36.       Integer*4 hinst,ierr 
  37.       Integer*4 hWndEdit,hwnd,hwndmain
  38.       Integer*4 hwndbutton1,hwndbutton2,hwndItem(20)
  39.       common/glob/ TextBuffer,hinst,hWndEdit,hWndItem,
  40.      1 hwndbutton1,hwndbutton2,formtext,item,value,
  41.      2 numitems,numcommentlines,isize,confirm
  42.       equivalence (formt,formtext)
  43.       data base_small_letters/96/
  44.       formtext=formtext1
  45.       isize=1
  46.       numitems=0
  47.       if(formt(1).gt.base_small_letters) formt(1)=formt(1)-32
  48.       numcommentlines=0
  49.       do while(isize.lt.2000.and.formtext(isize:isize).ne.term)
  50. c        convert lower to upper case if necessary
  51.          if(formtext(isize:isize).eq.'|'.and.formt(isize+1).gt.
  52.      1    base_small_letters) formt(isize+1)=formt(isize+1)-32
  53.          if(formtext(isize:isize).eq.'|'.and.
  54.      1    formtext(isize+1:isize+1).ne.'T'.and.
  55.      2    formtext(isize+1:isize+1).ne.'H') numitems=numitems+1
  56.          if(formtext(isize:isize).eq.'\') 
  57.      1    numcommentlines=numcommentlines+1
  58.          isize=isize+1
  59.       end do
  60.       if(formtext(1:1).eq.'T'.or.formtext(1:1).eq.'H') 
  61.      1 numitems=numitems-1
  62.       isize=isize-1
  63.       do j=1,numitems
  64.          item(j)=itemselected(j)
  65.          value(j)=valueitem(j)
  66.       enddo
  67.       TextBuffer=''c
  68.       if(init(hinstance,hwndmain,hwnd)
  69.      1 .eq.TRUE) ierr=msgloop(hinstance,hwnd)
  70.       form=confirm
  71.       if(confirm) then
  72.          do j=1,numitems
  73.             itemselected(j)=item(j)
  74.             valueitem(j)=value(j)
  75.          enddo
  76.       endif
  77.       return
  78.       end
  79.  
  80.        Integer*4 Function Init(
  81.      1 hInstance,hwndmain,hwnd)
  82.        include 'form32.fd'
  83.        external wndproc
  84.        Integer*4 hInstance,hPrev,nCmdShow
  85.        Integer*4 CreateWindowEx,loadcursor,registerclass
  86.       Character*80 TextBuffer 
  87.       character*2000 formtext
  88.       Integer*4 hinst,hwndmain 
  89.       Integer*4 hWndEdit 
  90.       Integer*4 hwndbutton1,hwndbutton2,hwndItem(20)
  91.       integer*1 item(20)
  92.       logical*1 confirm
  93.       real*8 value(20)
  94.       common/glob/ TextBuffer,hinst,hWndEdit,hWndItem,
  95.      1 hwndbutton1,hwndbutton2,formtext,item,value,
  96.      1 numitems,numcommentlines,isize,confirm
  97.       record /wndclass/ windowclass
  98.         Integer*4   hWnd
  99. c       integer*4 idc_arrow
  100. c       data idc_arrow/32512/
  101.         data hprev/false/
  102.       Init = true
  103. c     assign value to global variable for use in WndProc
  104.       hinst = hInstance
  105. c     if no previous instance of the application fill in WNDCLASS
  106.       if (hPrev.eq.false) then
  107.          WindowClass.lpszClassName = locfar('FORM_ENTRY'C)
  108.          WindowClass.hInstance     = hInstance
  109.          WindowClass.lpfnWndProc   = locfar(wndproc)
  110.          WindowClass.hCursor       = LoadCursor(null,idc_arrow)
  111.          WindowClass.hIcon         = NULL
  112.          WindowClass.lpszMenuName  = NULL
  113.          WindowClass.hbrBackground = COLOR_WINDOW + 1
  114.          WindowClass.style         = 0
  115.          WindowClass.cbClsExtra    = 0
  116.          WindowClass.cbWndExtra    = 0
  117.          hprev=true
  118. c        Register the class
  119.          if (RegisterClass (WindowClass).eq.false) Init = false
  120.       end if
  121.       hWnd = CreateWindowEx(0, locfar('FORM_ENTRY'C),locfar('FORM'C),            
  122.      1 WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,0,CW_USEDEFAULT,0,hWndMain,               
  123.      1 NULL,hInstance,NULL)           
  124. c     show the window as it is not visible by default
  125.       nCmdShow=sw_shownormal
  126.       call ShowWindow (hWnd,nCmdShow)
  127.       call UpdateWindow(hWnd)
  128.       return 
  129.       end
  130.  
  131.       Integer*4 Function MsgLoop(hinstance,hwnd)
  132.        include 'form32.fd'
  133.        Integer*4 idm_itemup,idm_itemdown,idm_escape,idm_confirm
  134.        Integer*4 return,escape,control_backspace,control_return
  135.        parameter (return=13)
  136.        parameter (escape=27)
  137.        parameter (tab=9)
  138.        parameter (control_backspace=127)
  139.        parameter (control_return=10)
  140.       parameter (idm_itemup=301)
  141.       parameter (idm_itemdown=302)
  142.       parameter (idm_escape=303)
  143.       parameter (idm_confirm=304)
  144.        Integer*4 hinstance,hwnd
  145.        Record /tagmsg/ msg
  146.        integer*4 SendMessage
  147.        integer*4 lberr
  148.        Integer*4 GetMessage
  149.       DO WHILE (GetMessage(msg,null,0,0).ne.false)
  150.           if(msg.message.eq.WM_Char.and.(msg.wparam.eq.return.or.
  151.      1     msg.wparam.eq.tab)) then
  152.                lberr=SendMessage(hwnd,WM_COMMAND,IDM_itemdown,1)
  153.           else if(msg.message.eq.WM_Char.and.msg.wparam.eq.
  154.      1     control_return) then
  155.                lberr=SendMessage(hwnd,WM_COMMAND,IDM_confirm,1)
  156.           else if(msg.message.eq.WM_Char.and.msg.wparam.eq.escape) then
  157.                lberr=SendMessage(hwnd,WM_COMMAND,IDM_escape,1)
  158.           else if(msg.message.eq.WM_Char.and.msg.wparam.eq.
  159.      1     control_backspace) then
  160.                lberr=SendMessage(hwnd,WM_COMMAND,IDM_itemup,1)
  161.           else
  162.              Call TranslateMessage(msg)
  163.              Call DispatchMessage(msg)
  164.           endif
  165.         MsgLoop=msg.wParam
  166.       End Do
  167.       return
  168.       end
  169.  
  170.        INTERFACE TO SUBROUTINE MOVETEXT 
  171.      1  (A,ANS)
  172.        character*(*) A [REFERENCE]
  173.        Integer*4 ANS [VALUE]
  174.        END
  175.  
  176.        INTERFACE TO SUBROUTINE MOVEBACK 
  177.      1  (A,ANS)
  178.        character*(*) A [REFERENCE]
  179.        Integer*4 ANS [VALUE]
  180.        END
  181.  
  182.       Integer*4 Function wndproc [PASCAL,LOADDS,
  183.      1alias:'_WNDPROC']
  184.      1 (hWnd[VALUE],wMsgID[VALUE],wParam[VALUE],lParam[VALUE])
  185.       include 'form32.fd'
  186.       Integer*4 idokbutton,idcancelbutton,idm_itemup,idm_itemdown
  187.       Integer*4 idbutton1,idbutton2,idbutton3,idbutton4,idbutton5
  188.       Integer*4 idbutton6,idbutton7,idbutton8,idbutton9,idbutton10
  189.       Integer*4 idbutton11,idbutton12,idbutton13,idbutton14,idbutton15
  190.       Integer*4 idbutton16,idbutton17,idbutton18,idbutton19,idbutton20
  191.       Integer*4 iditem1,iditem2,iditem3,iditem4,iditem5,idm_confirm
  192.       Integer*4 iditem6,iditem7,iditem8,iditem9,iditem10
  193.       Integer*4 iditem11,iditem12,iditem13,iditem14,iditem15
  194.       Integer*4 iditem16,iditem17,iditem18,iditem19,iditem20
  195.       character*1 term,space
  196.       real*4 big
  197.       logical*1 listdown(30)
  198.       character*1 pulldown
  199.       parameter (pulldown='~')
  200.       parameter (big=1.0E13)
  201.       parameter (term=0)
  202.       parameter (space=' ')
  203.       parameter (idokbutton=200)
  204.       parameter (idcancelbutton=201)
  205.       parameter (iditem1=202)
  206.       parameter (iditem2=203)
  207.       parameter (iditem3=204)
  208.       parameter (iditem4=205)
  209.       parameter (iditem5=206)
  210.       parameter (iditem6=207)
  211.       parameter (iditem7=208)
  212.       parameter (iditem8=209)
  213.       parameter (iditem9=210)
  214.       parameter (iditem10=211)
  215.       parameter (iditem11=212)
  216.       parameter (iditem12=213)
  217.       parameter (iditem13=214)
  218.       parameter (iditem14=215)
  219.       parameter (iditem15=216)
  220.       parameter (iditem16=217)
  221.       parameter (iditem17=218)
  222.       parameter (iditem18=219)
  223.       parameter (iditem19=220)
  224.       parameter (iditem20=221)
  225.       parameter (idm_itemup=301)
  226.       parameter (idm_itemdown=302)
  227.       parameter (idm_escape=303)
  228.       parameter (idm_confirm=304)
  229.       parameter (idbutton1=305)
  230.       parameter (idbutton2=306)
  231.       parameter (idbutton3=307)
  232.       parameter (idbutton4=308)
  233.       parameter (idbutton5=309)
  234.       parameter (idbutton6=310)
  235.       parameter (idbutton7=311)
  236.       parameter (idbutton8=312)
  237.       parameter (idbutton9=313)
  238.       parameter (idbutton10=314)
  239.       parameter (idbutton11=315)
  240.       parameter (idbutton12=316)
  241.       parameter (idbutton13=317)
  242.       parameter (idbutton14=318)
  243.       parameter (idbutton15=319)
  244.       parameter (idbutton16=320)
  245.       parameter (idbutton17=321)
  246.       parameter (idbutton18=322)
  247.       parameter (idbutton19=323)
  248.       parameter (idbutton20=324)
  249.       Integer*4 hwndit,none
  250.       parameter (hwndit=201)
  251.       Integer*4 hWnd,wMsgID,wParam,hparent,iditem(20),idbutton(20)
  252.       Integer*4 lParam,lberr,lselected
  253.       Character*80 TextBuffer 
  254.       Character*2000 formtext
  255.       Integer*4 hinst 
  256.       Integer*4 SelectObject,GetWindowText
  257.       integer*4 i,nowitem
  258.       Integer*4 hWndEdit,xmax,ymax 
  259.       Integer*4 hwndbutton1,hwndbutton2,hwndItem(20),buttonindex(20)
  260.       Integer*4 hwndbuttons(20),numbuttonsrow(20),button_item(20)
  261.       integer*1 item(20)
  262.       logical*1 confirm
  263.       character*1 select_indicator(25)
  264.       real*8 value(20)
  265.       common/glob/ TextBuffer,hinst,hWndEdit,hWndItem,
  266.      1 hwndbutton1,hwndbutton2,formtext,item,value,
  267.      2 numitems,numcommentlines,isize,confirm
  268.       integer*4 defwindowproc
  269.        integer*4 ws_mybutton,loword,hiword,current_item
  270.       Integer*4 CreateWindowEx,setfocus,destroywindow
  271.       Integer*4 SetBkMode,BeginPaint,TextOut
  272.       Integer*4 cxChar,cyChar,hdc,ierr,numread
  273.       Integer*4 GetDC,GetTextMetrics,GetStockObject,ReleaseDC
  274.       INTEGER*4 ipreviouscolor
  275.       integer*4 SetTextColor,SetBkColor,GetSysColor
  276.       integer*4 SendMessage
  277.       character*60 textbuf(25)
  278.       character*30 buttontext(8)
  279.       logical*1 precarettext,errflag
  280.       character entrytype,icharnow,itemtypebuf(20)
  281.       Record /tagTextMetric/ tm
  282.       Record /tagRect/ rect
  283.       Record /tagPAINTSTRUCT/ ps
  284.       integer*4 value_int4
  285.       integer*2 value_int2
  286.       integer*4 charcount
  287.       real*4 value_real4
  288.       real*8 val
  289.       integer*4 ws_dropdown
  290.       integer*4 ws_dropdownlist
  291.       Equivalence(value_int4,value_int2,value_real4,val)
  292.       data ws_mybutton/#50000000/
  293.       data ws_dropdown/#50A00002/
  294.       data ws_dropdownlist/#50A00003/
  295.       data idbutton/idbutton1,idbutton2,idbutton3,idbutton4,idbutton5,
  296.      1  idbutton6,idbutton7,idbutton8,idbutton9,idbutton10,
  297.      2  idbutton11,idbutton12,idbutton13,idbutton14,idbutton15,
  298.      3  idbutton16,idbutton17,idbutton18,idbutton19,idbutton20/
  299.       data iditem/iditem1,iditem2,iditem3,iditem4,iditem5,
  300.      1  iditem6,iditem7,iditem8,iditem9,iditem10,
  301.      2  iditem11,iditem12,iditem13,iditem14,iditem15,
  302.      3  iditem16,iditem17,iditem18,iditem19,iditem20/
  303. c     return TRUE unless unless handles by DefWindowProc
  304.       wndproc = true
  305.       select case (wMsgID)
  306.          case (WM_CREATE)
  307.            ibuttontotal=0
  308.            icurbutton=0
  309.            hdc=GetDC(hWnd)
  310.            ierr=SelectObject(hdc,GetStockObject(SYSTEM_FIXED_FONT))
  311.            ierr=GetTextMetrics(hdc,tm)
  312.            cxChar=tm.tmAveCharWidth
  313.            cyChar=tm.tmHeight+tm.tmExternalLeading
  314.            ierr=ReleaseDC(hwnd,hdc)
  315.            numlines=numitems+numcommentlines
  316.            do i=1,numlines
  317.               select_indicator(i)=space
  318.               listdown(i)=.false.
  319.            enddo
  320.            ysc=2.
  321.            yscbox=7./4.
  322.            o=1.
  323. c          reduce dimensions if long form
  324.            if(numlines.gt.10) then
  325.               ysc=1.2
  326.               yscbox=1.2
  327.               o=0.
  328.            endif
  329.            ymax=(numlines+4)*cyChar*ysc
  330.            if(numlines.gt.10) ymax=(numlines+4.3)*cychar*ysc
  331.            xmax=64*cxChar
  332.            Call MoveWindow (hWnd,0,0,xmax,ymax,1)
  333.            entrytype=formtext(1:1)
  334.            precarettext=.TRUE.
  335.            line=0
  336.            linecomment=0
  337.            lineentry=0
  338.            itemstart=2
  339.            j=2
  340.            do while (j.le.isize) 
  341.             icharnow=formtext(j:j)
  342.             select case (icharnow)
  343.              case('^')
  344.               itemend=j-1
  345.               icharcount=j-itemstart
  346.               if(precarettext) then
  347.                line=line+1
  348.                lineentry=lineentry+1
  349.                textbuf(line)(1:icharcount)=
  350.      1          formtext(itemstart:itemend)
  351.                if(icharcount.lt.30) then
  352.                  do m=icharcount+1,30
  353.                    textbuf(line)(m:m)=space
  354.                  end do
  355.                endif
  356.                textbuf(line)(31:31)=term
  357.                m=lineentry
  358.                i=line-1
  359.                select case(entrytype)
  360.                 case('B')  !count buttons on this row save text
  361.                   ibuttonrow=1
  362.                   ibuttontotal=ibuttontotal+1
  363.                   buttontext(ibuttonrow)(1:icharcount)=
  364.      1             formtext(itemstart:itemend)
  365.                   buttontext(ibuttonrow)(icharcount+1:icharcount+1)=
  366.      1             term
  367.                 case('I')  !integer*2
  368.                   hWndItem(m) = CreateWindowEx(0,locfar('combobox'c),
  369.      1             locfar(''c),WS_DropDown,30*cxChar,cyChar*(o+ysc*i),
  370.      2             30*cxCHar,yscbox*cyChar*6,hWnd,IDitem(m),hinst,NULL)
  371.                   val=value(m)
  372.                   write(TextBuffer,1) value_int2,term
  373. 1                 format(I8,a1)
  374.                   call squash_int(Textbuffer)
  375.                   call SetWindowText(hWndItem(m),TextBuffer)
  376.                 case('R')  !real*4
  377.                   hWndItem(m) = CreateWindowEx(0,locfar('combobox'c),
  378.      1             locfar(''c),WS_DropDown,30*cxChar,cyChar*(o+ysc*i),
  379.      2            30*cxCHar,yscbox*cyChar*6,hWnd,IDitem(m),hinst,NULL)
  380.                    val=value(m)
  381.                    if(value_real4.lt.1..and.-value_real4.lt.1.) then
  382.                      write(TextBuffer,2) value_real4,term
  383. 2                    format(f29.27,a1)
  384.                    else if (value_real4.gt.big.or.
  385.      1              -value_real4.gt.big) then
  386.                      write(TextBuffer,9) value_real4,term
  387. 9                    format(f29.0,a1)
  388.                    else
  389.                      write(TextBuffer,3) value_real4,term
  390. 3                    format(f29.14,a1)
  391.                    endif
  392.                    call squash_real(textbuffer)
  393.                    call SetWindowText(hWndItem(m),TextBuffer)
  394.                  case('S')  !choice
  395.                    hWndItem(m) = CreateWindowEx(0,locfar('combobox'c),
  396.      1              locfar(''c),WS_DropDownList,30*cxChar,cyChar*(o+ysc
  397.      2              *i),30*cxCHar,yscbox*cyChar*6,hWnd,IDitem(m),hinst,
  398.      3              NULL)
  399.                  case('C')  !string
  400.                    hWndItem(m) = CreateWindowEx(0,locfar('combobox'c),
  401.      1              locfar(''c),WS_DropDown,30*cxChar,cyChar*(o+ysc*i),
  402.      2             30*cxCHar,yscbox*cyChar*6,hWnd,IDitem(m),hinst,NULL)
  403.                    val=value(m)
  404.                    if(value_int4.ne.null) 
  405.      1              call moveback(TextBuffer,value_int4)
  406.                    call SetWindowText(hWndItem(m),TextBuffer)
  407.                  case('D')  !real*8
  408.                    hWndItem(m) = CreateWindowEx(0,locfar('combobox'c),
  409.      1             locfar(''c),WS_DropDown,30*cxChar,cyChar*(o+ysc*i),
  410.      2             30*cxCHar,yscbox*cyChar*6,hWnd,IDitem(m),hinst,NULL)
  411.                    val=value(m)
  412.                    if(val.lt.1..and.-val.lt.1.) then
  413.                       write(TextBuffer,2) val,term
  414.                    else if (val.gt.big.or.-val.gt.big) then
  415.                      write(TextBuffer,9) value_real4,term
  416.                    else
  417.                       write(TextBuffer,3) val,term
  418.                    endif
  419.                    call squash_real(textbuffer)
  420.                    call SetWindowText(hWndItem(m),TextBuffer)
  421.                  case('L')  !integer*4
  422.                    hWndItem(m) = CreateWindowEx(0,locfar('combobox'c),
  423.      1              locfar(''c),WS_Dropdown,30*cxChar,cyChar*(o+ysc*i),
  424.      2             30*cxCHar,yscbox*cyChar*6,hWnd,IDitem(m),hinst,NULL)
  425.                    val=value(m)
  426.                    write(TextBuffer,4) value_int4,term
  427. 4                  format(I18,a1)
  428.                    call squash_int(TextBuffer)
  429.                    call SetWindowText(hWndItem(m),TextBuffer)
  430.                  end select
  431.               else
  432. c              add item to list
  433.                itemend=j-1
  434.                icharcount=j-itemstart
  435.                TextBuffer(1:icharcount)=
  436.      1          formtext(itemstart:itemend)
  437.                TextBuffer(icharcount+1:icharcount+1)=0
  438.                if(entrytype.eq.'B') then
  439.                   ibuttonrow=ibuttonrow+1
  440.                   ibuttontotal=ibuttontotal+1
  441.                   buttontext(ibuttonrow)=textbuffer
  442.                else
  443.                   listdown(m)=.true.
  444.                   lberr=SendMessage(hwnditem(m),CB_AddString,-1,
  445.      1             locfar(TextBuffer))
  446.                   select_indicator(line)=pulldown
  447.                endif
  448.               endif
  449.               itemstart=j+1
  450.               precarettext=.FALSE.
  451.              case('\')
  452.               itemend=j-1
  453.               icharcount=j-itemstart
  454.               line=line+1
  455.               linecomment=linecomment+1
  456.               textbuf(line)(1:icharcount)=
  457.      1         formtext(itemstart:itemend)
  458.                if(icharcount.lt.60) then
  459.                  do m=icharcount+1,60
  460.                    textbuf(line)(m:m)=space
  461.                  end do
  462.                  nrear=(60-icharcount)
  463.                  nfront=nrear/2
  464.                  nrear=nrear-nfront
  465.                  if(nfront.ge.1) then
  466.                     do m=60-nrear,nfront,-1
  467.                        mm=m-nfront
  468.                        textbuf(line)(m:m)=textbuf(line)(mm:mm)
  469.                     enddo
  470.                     do m=1,nfront
  471.                        textbuf(line)(m:m)=space
  472.                     enddo
  473.                  endif
  474.                endif
  475.                itemstart=j+1
  476.              case('|')
  477.                 select case(entrytype)
  478.                   case('I','R','S','C','D','L')
  479.                     itemtypebuf(lineentry)=entrytype
  480.                   case('T')  !comment
  481.                   case('H')  !form title
  482.                     itemend=j-1
  483.                     icharcount=j-itemstart
  484.                     TextBuffer(1:icharcount)=
  485.      1               formtext(itemstart:itemend)
  486.                     call SetWindowText(hWnd,TextBuffer)
  487.                   case('B')  ! make row of action buttons
  488.                      itemtypebuf(lineentry)=entrytype
  489.                      ibuttonrownow=1
  490.                      ipos=1
  491.                      iwidth=60/ibuttonrow
  492.                      iwsize=iwidth-1
  493.                      ibuttonbase=ibuttontotal-ibuttonrow
  494.                      do i=ibuttonbase+1,ibuttontotal
  495.                       textbuffer=buttontext(ibuttonrownow)
  496.                       hWndbuttons(i) = CreateWindowEx(0,
  497.      1                 locfar('button'c),
  498.      1                 locfar(TextBuffer),WS_MyButton,cxChar*ipos,
  499.      2                 cyChar*(o+ysc*(line-1)),iwsize*cxChar,yscbox*
  500.      3                 cyChar,hWnd,IDbutton(i),hinst,NULL)
  501.                       button_item(i)=lineentry
  502.                       ibuttonrownow=ibuttonrownow+1
  503.                       ipos=iwidth+ipos
  504.                      enddo
  505.                      textbuf(line)(1:1)=term
  506.                      numbuttonsrow(lineentry)=ibuttonrow
  507.                      buttonindex(lineentry)=ibuttonbase
  508.                 end select
  509.                 j=j+1
  510.                 if(j.le.isize) entrytype=formtext(j:j)
  511.                 itemstart=j+1
  512.                 precarettext=.TRUE.
  513.              case default
  514.             end select
  515.             j=j+1
  516.            end do
  517.            do m=1,numitems
  518.               nowitem=item(m)-1
  519. c              if(itemtypebuf(m).eq.'S'.or.item(m).ne.term) then
  520.               if(itemtypebuf(m).eq.'S'.or.listdown(m)) then
  521.                  if(itemtypebuf(m).eq.'S'.or.item(m).ne.term) then
  522.                     lberr=SendMessage(hwnditem(m),CB_SETCURSEL,
  523.      1               nowitem,null)
  524.                  endif
  525.                  lberr=SendMessage(hwnditem(m),CB_SETITEMHEIGHT,0,
  526.      1            yscbox*cyChar)
  527.                  lberr=SendMessage(hwnditem(m),CB_SETITEMHEIGHT,-1,
  528.      1            yscbox*cyChar)
  529.               else
  530.                  lberr=SendMessage(hwnditem(m),CB_SETITEMHEIGHT,0,
  531.      1            yscbox*cyChar*7)
  532.               endif
  533.            end do
  534.            hWndEdit=hWndItem(1)
  535.            current_item=1
  536.            i=numlines
  537. c          create a window of the "pushbutton" class
  538.            hWndbutton1 = CreateWindowEx(0,locfar('button'c),
  539.      1      locfar('O.K.'c),WS_MyButton,cxChar,cyChar*(o+ysc*i),
  540.      2      26*cxChar,yscbox*cyChar,hWnd,IDOKbutton,hinst,NULL)
  541.            hWndbutton2 = CreateWindowEx(0,locfar('button'c),
  542.      1      locfar('CANCEL'c),WS_MyButton,32*cxChar,cyChar*(o+ysc*i),
  543.      2      26*cxCHar,yscbox*cyChar,hWnd,IDCANCELbutton,hinst,NULL)
  544.        case (WM_PAINT)
  545.           hDC=BeginPaint(hWnd,ps)
  546.           ierr=SelectObject(hDC,GetStockObject(SYSTEM_FIXED_FONT))
  547.            ierr=GetTextMetrics(hDC,tm)
  548.            cxChar=tm.tmAveCharWidth
  549.            cyChar=tm.tmHeight+tm.tmExternalLeading
  550.           ierr=SetBkMode(hDC,TRANSPARENT)
  551.           ipreviouscolor=SetTextColor(hdc,
  552.      1      GetSysColor(COLOR_WINDOWTEXT))
  553.           ipreviouscolor=SetBkColor(hdc,GetSysColor(COLOR_WINDOW))
  554.           do j=1,numlines
  555.              i=j-1
  556.              charcount=60
  557.              if(textbuf(j)(31:31).eq.term) charcount=30
  558.              If(textbuf(j)(1:1).ne.term) Ierr=Textout(hDC,cxChar,
  559.      1        cyChar*(o+ysc*i),textbuf(j),charcount)
  560.              Ierr=Textout(hDC,60.7*cxChar,cyChar*(o+.3+ysc*i),
  561.      1        select_indicator(j),1)
  562.           end do
  563.           i=numlines+2
  564.           TextBuffer=
  565.      1     'ENTER or TAB=down   CTRL-BACKSPACE=up   ESCAPE = Cancel'
  566.           Ierr=Textout(hDC,cxChar,cyChar*(ysc*i+o-1),TextBuffer,55)
  567.           TextBuffer=
  568.      1     'SPACE BAR presses button       CNTR-ENTER=confirms form'
  569.           Ierr=Textout(hDC,cxChar,cyChar*(o+ysc*i),TextBuffer,55)
  570.           Call EndPaint(hwnd,ps)
  571.       case (WM_SETFOCUS)
  572. c        give the current window focus for keyboard input
  573.          if (numitems.eq.0) hWndEdit=hwndbutton1
  574.          hparent=SetFocus (hWndEdit)
  575.       case (WM_COMMAND)
  576.          select case (wParam)
  577.              case (IDbutton1:IDbutton20,IDOKbutton,IDM_CONFIRM)
  578.                 if(wparam.eq.IDM_CONFIRM.OR.HiWord(wParam).eq.
  579.      1           BN_CLICKED) then
  580.                   confirm=.TRUE.
  581.                   errflag=.true.
  582.                   do current_item=1,numitems
  583.                      entrytype=itemtypebuf(current_item)
  584.                      if(entrytype.eq.'B') then
  585.                         lselected=-1
  586.                         ibuttonnum=wParam-IDM_CONFIRM
  587.                         if(button_item(ibuttonnum).eq.current_item) 
  588.      1                   lselected=ibuttonnum-
  589.      2                   buttonindex(current_item)-1
  590.                      else
  591.                         lselected=SendMessage(hwnditem(current_item),
  592.      1                   CB_GETCURSEL,none,not_used)
  593.                         if(lselected.eq.CB_ERR) lselected=-1
  594.                      endif
  595.                      item(current_item)=lselected+1
  596.                      numread=GetWindowText(hwndItem(current_item),
  597.      1                 TextBuffer,80)
  598.                      if(itemtypebuf(current_item).ne.'C'.and.
  599.      1                numread.lt.1.and.item(current_item).eq.term) then
  600.                        numread=1
  601.                        textbuffer(1:1)='0'
  602.                      endif
  603.                      if(itemtypebuf(current_item).ne.'C'.and.numread
  604.      1                .lt.30.and.item(current_item).eq.term) then
  605.                          numfront=30-numread
  606.                          do j=30,1,-1
  607.                             if(j.le.numfront) then
  608.                                Textbuffer(j:j)=space
  609.                             else
  610.                                jj=j-numfront
  611.                                Textbuffer(j:j)=textbuffer(jj:jj)
  612.                             endif
  613.                          enddo
  614.                      endif
  615. 18                   format(I3,5x,a)
  616.                     if(item(current_item).eq.term) then
  617.                      Select Case (entrytype)
  618.                       CASE('C') !text string
  619.                        Textbuffer(numread+1:numread+1)=term
  620.                        val=value(current_item)
  621.                        if(value_int4.ne.null) 
  622.      1                  call movetext(TextBuffer,value_int4)
  623.                       case('I') !integer*2
  624.                        read(textbuffer,10,err=14) value_int2
  625. 10                     format(i30)
  626.                        value(current_item)=val
  627.                       case('R') !real*4
  628.                        read(textbuffer,11,err=14) value_real4
  629. 11                     format(f30.0)
  630.                        value(current_item)=val
  631.                       case('L') !integer*4
  632.                        read(textbuffer,10,err=14) value_int4
  633.                        value(current_item)=val
  634.                       case('D') !real*8
  635.                        read(textbuffer,11,err=14) val
  636.                        value(current_item)=val
  637.                      EndSelect
  638.                     endif
  639.                   end do
  640.                   errflag=.false.
  641. 14                if(errflag) then
  642.                      hwndEdit=hwndItem(current_item)
  643.                      hparent=SetFocus (hWndEdit)
  644.                   else
  645.                      nerr=destroywindow(hwnd)
  646.                   endif
  647.                 endif
  648.              case (IDCANCELbutton,IDM_ESCAPE)
  649.                 if(wparam.eq.IDM_ESCAPE.OR.HiWord(wParam).eq.
  650.      1           BN_CLICKED) then
  651.                   confirm=.FALSE.
  652.                   nerr=destroywindow(hwnd)
  653.                 endif
  654.               case (IDM_ITEMDOWN)
  655.                  if(itemtypebuf(current_item).eq.'B') then
  656.                    icurbutton=icurbutton+1
  657.                    if(icurbutton.le.numbuttonsrow(current_item)) then
  658.                       current_item=current_item-1
  659.                    else
  660.                       icurbutton=0
  661.                    endif
  662.                  else
  663.                     icurbutton=0
  664.                  endif
  665.                  k=current_item+1
  666.                  if(k.gt.numitems+2) k=1
  667.                  current_item=k
  668.                  if(k.le.numitems) then
  669.                     hwndEdit=hwndItem(k)
  670.                     if(itemtypebuf(k).eq.'B') then
  671.                        if(icurbutton.eq.0) icurbutton=1
  672.                        hwndEdit=hwndbuttons(buttonindex(k)+
  673.      1                  icurbutton)
  674.                     endif
  675.                  else if(k.eq.numitems+1) then
  676.                     hwndEdit=hwndbutton1
  677.                     icurbutton=0
  678.                  else
  679.                     hwndEdit=hwndbutton2
  680.                     icurbutton=0
  681.                  endif
  682.                  hparent=SetFocus (hWndEdit)
  683.               case (IDM_ITEMUP)
  684.                  if(itemtypebuf(current_item).eq.'B') then
  685.                    if(icurbutton.eq.0) icurbutton=
  686.      1              numbuttonsrow(current_item)+1
  687.                    icurbutton=icurbutton-1
  688.                    if(icurbutton.gt.0) then
  689.                       current_item=current_item+1
  690.                    else
  691.                       icurbutton=0
  692.                    endif
  693.                  else
  694.                     icurbutton=0
  695.                  endif
  696.                  k=current_item-1
  697.                  if(k.lt.1) k=numitems+2
  698.                  current_item=k
  699.                  if(k.le.numitems) then
  700.                     hwndEdit=hwndItem(k)
  701.                     if(itemtypebuf(k).eq.'B') then
  702.                        if(icurbutton.eq.0) icurbutton=
  703.      1                  numbuttonsrow(current_item)
  704.                        hwndEdit=hwndbuttons(buttonindex(k)+
  705.      1                  icurbutton)
  706.                     endif
  707.                  else if(k.eq.numitems+1) then
  708.                     hwndEdit=hwndbutton1
  709.                     icurbutton=0
  710.                  else
  711.                     hwndEdit=hwndbutton2
  712.                     icurbutton=0
  713.                  endif
  714.                  hparent=SetFocus (hWndEdit)
  715.          END SELECT
  716.       case (WM_CLOSE)
  717.          nerr=destroywindow(hwnd)
  718.       case (WM_DESTROY)
  719.          Call PostQuitMessage(0)
  720.       case DEFAULT
  721.          wndproc = DefWindowProc (hWnd, 
  722.      1    wMsgID, wParam, lParam)
  723.       END SELECT
  724.       return
  725.       end
  726.       
  727.       Integer*4 Function LOWORD(lParam)
  728.       Integer*4 lparam,mparam
  729.       Integer*2 kparam(2)
  730.       Equivalence (mparam,kparam(1))
  731.       mparam=lparam
  732.       LOWORD=kparam(1)
  733.       return
  734.       end
  735.  
  736.       Integer*4 Function HIWORD(lParam)
  737.       Integer*4 lparam,mparam
  738.       Integer*2 kparam(2)
  739.       Equivalence (mparam,kparam(1))
  740.       mparam=lparam
  741.       HIWORD=kparam(2)
  742.       return
  743.       end
  744.  
  745.       Subroutine Squash_Int(TextBuffer)
  746.       Character*80 TextBuffer 
  747.       character*1 term
  748.       data term/0/
  749.       TextBuffer(31:31)=term
  750.       do while (TextBuffer(1:1).eq.' ')
  751.          do j=1,30
  752.             TextBuffer(j:j)=TextBuffer(j+1:j+1)
  753.          enddo
  754.       enddo
  755.       return
  756.       end
  757.       
  758.       Subroutine Squash_Real(TextBuffer)
  759.       Character*80 TextBuffer 
  760.       character*1 term
  761.       character*4 zero
  762.       data term/0/,zero/'0.0\0'c/
  763.       Call Squash_int(TextBuffer)
  764.       i=1
  765.       do while (TextBuffer(i:i).ne.term)
  766.          i=i+1
  767.       enddo
  768.       if(i.gt.1) i=i-1
  769.       do while(TextBuffer(i:i).eq.'0')
  770.          TextBuffer(i:i)=term
  771.          i=i-1
  772.       enddo
  773.       if(i.le.1) TextBuffer(1:4)=zero
  774.       return
  775.       end
  776.