home *** CD-ROM | disk | FTP | other *** search
/ AMOS PD CD / amospdcd.iso / 176-200 / apd176 / dbm_sys / dbm-enquire.amos / dbm-enquire.amosSourceCode
AMOS Source Code  |  1991-03-11  |  10KB  |  361 lines
  1. Set Buffer 40
  2. '
  3. ' Database master Detailed Reports by Steve (05/02/91)   
  4. '
  5. FLD_SETUP:
  6. Close Editor 
  7. Dim DBFN$(50)
  8. Dim DBFL$(50)
  9. Dim INFO$(50)
  10. Dim DBRPW$(50)
  11. Dim DBWPW$(50)
  12. Dim CONF$(400)
  13. Screen Open 0,640,260,16,Hires
  14. 'Break Off 
  15. On Error Goto EROR
  16. Global FILENAME$,ICON$,DISK$,PIC$,REC_COUNT,PROGRAMS$,NED,CONF$(),THE_LEGHT,THE_LINES,THE_RECORDS
  17. '
  18. Reserve As Work 10,15000
  19. '
  20. Screen Open 0,640,208,4,Hires : Curs Off 
  21. Screen Display 0,,50,,
  22. '
  23. Open In 9,"DBM_SYS:DBMPROG.DAT"
  24. Input #9,DISK$
  25. Input #9,ACCOUNT$
  26. Close 9
  27. PROGRAMS$=DISK$+ACCOUNT$
  28. CHAIN_PROG$=PROGRAMS$+"DBM-MASTER.AMOS"
  29. BEGIN:
  30. 'Doke ADATA+38,22
  31. 'Curs Off  
  32. 'Paper 0 
  33. 'Cls 
  34. 'Curs Off  
  35. 'Wind Open 1,1,1,79,5,1
  36. 'Paper 4 : Pen 3 : Clw 
  37. 'Locate 18,2 : Print "    D A T A B A S E  M A S T E R    "
  38. 'Wind Open 2,1,33,79,28,14 
  39. 'Paper 6 : Pen 5 : Clw 
  40. '
  41. If Not Exist("RAM:DBMCHAIN.DAT")
  42.    Cls 
  43.    Print "Chain file missing return to main menu.  C/R to Recover."
  44.    Wait Key 
  45.    Goto EX_PROG
  46. End If 
  47. Open In 9,"RAM:DBMCHAIN.DAT"
  48. Input #9,FILENAME$
  49. Close 9
  50. '
  51. Open Out 9,"RAM:DBMLINK.DAT"
  52. Print #9,"By pass the select database option. Database - ";FILENAME$
  53. Close 9
  54. '
  55. '
  56. Gosub OPEN_FILES
  57. '
  58.    THE_LEGHT=A
  59.    If Val(DBUSE$)<15 Then THE_LINES=Val(DBUSE$)
  60.    If Val(DBUSE$)>15 Then THE_LINES=15
  61.    THE_RECORDS=Val(DBUSE$)
  62. '
  63. For LP=1 To Val(DBUSE$)
  64.    Get 3,LP
  65.    CONF$(LP)=A$
  66. Next LP
  67. '
  68. Gosub ST_EDIT
  69. '
  70. Stop 
  71. '------------------------------------------------------------------------- 
  72. ST_EDIT:
  73. '
  74.    LED=THE_LINES
  75.    NED=THE_RECORDS
  76.    Dim ED$(400)
  77.    NN=1
  78.    '
  79.    For LP=1 To Val(DBUSE$)
  80.       ED$(LP)=CONF$(LP)
  81.    Next LP
  82.    '
  83.    '==============================================================
  84.    '
  85.    ' Open edit window 
  86.    '  
  87.    Reserve Zone 30
  88.    If NED<>LED
  89.       ARROW[36,3*8,12,22,4,25] : ARROW[36,15*8,12,-22,4,27]
  90.    End If 
  91.    CASE[36,9*8,12,22,4,26]
  92.    VER_TEXT["Quit",4,7]
  93. '   Centre At(,19)+"Click on the string to edit."
  94. '   Centre At(,20)+"Important: some strings finish with a space, you should not remove it!"
  95. '   Centre At(,21)+"Are you working on a COPY of your language disk?"
  96.    Paper 2 : Pen 1 : Wind Open 1,8*8,8*(9-(THE_LINES+2)/2),70,THE_LINES+2,1 : Scroll Off 
  97.    PY=0 : ACT=0 : Gosub ALL_PRINT
  98.    Window 0 : Paper 1 : Pen 2
  99.    Window 1
  100.    '
  101.    ' Test for mouse 
  102.    '
  103.    Do 
  104.       Do 
  105.          Repeat 
  106.             Wait Vbl 
  107.             If AL : Dec AL : If AL=0 : ALERT[""] : End If : End If 
  108.             Z=Mouse Zone
  109. ''            If Z=<THE_LINES
  110.                If Z<>ACT
  111.                   If ACT>0 : NNN=ACT : ACT=0 : Gosub ST_PRINT_ALL : End If 
  112.                   If Z>0 and Z<=LED : ACT=Z : NNN=Z : Gosub ST_PRINT_ALL : End If 
  113.                End If 
  114. ''             End If    
  115.             If Mouse Key and Z>LED
  116.                Exit If Z=26,3
  117.                If LED<>NED
  118.                   If Z=25 and PY>0
  119.                      Home : Vscroll 1
  120.                      Dec PY : NNN=1 : Gosub ST_PRINT_ALL
  121.                   End If 
  122.                   If Z=27 and PY+LED<NED
  123.                      Locate 0,LED-1 : Vscroll 3
  124.                      Inc PY : NNN=LED : Gosub ST_PRINT_ALL
  125.                   End If 
  126.                End If 
  127.             End If 
  128.          Until ACT>0 and Mouse Key=1
  129.          FLAG=Deek(Varptr(ED$(ACT+PY))) : F=0
  130.          For NNN=8 To Len(ED$(ACT+PY))
  131.             If Mid$(ED$(ACT+PY),NNN,1)<>" " : Inc F : End If 
  132.          Next 
  133.          If F or Btst(11,FLAG) or(Btst(14,FLAG)=0)
  134.             Bset 11,FLAG : Exit 
  135.          Else 
  136.             AL=100 : ALERT["This string is not editable!"]
  137.          End If 
  138.       Loop 
  139.       While Mouse Key : Wend 
  140.       Inverse Off : Print Chr$(7);
  141.       '
  142.       ' Edit loop
  143.       '
  144. '
  145. 'Print "****** here **********" : Wait Key 
  146. '
  147.       ED$=CONF$(ACT)
  148.       XCU=0
  149.       LM=Len(ED$)
  150.       LMAX=THE_LEGHT
  151.       Do 
  152.          Curs Off : Locate 4,ACT-1 : Print ED$;
  153.          If Len(ED$)<LMAX : Print String$(".",LMAX-Len(ED$)); : End If 
  154.          Locate 4+XCU,ACT-1 : Curs On 
  155.          Repeat 
  156.             A$=Inkey$ : KY=Scancode
  157.             If Mouse Key : A$=Chr$(13) : End If 
  158.          Until A$<>""
  159.          If A$=Chr$(27) : ED$=Mid$(ED$(ACT+PY),9) : A$=Chr$(13) : End If 
  160.          Exit If A$=Chr$(13)
  161.          If KY=65 and XCU>0 : ED$=Left$(ED$,XCU-1)+Mid$(ED$,XCU+1) : KY=79 : End If 
  162.          If KY=70 : ED$=Left$(ED$,XCU)+Mid$(ED$,XCU+2) : KY=-1 : End If 
  163.          If KY=79 : XCU=Max(0,XCU-1) : KY=-1 : End If 
  164.          If KY=78 : XCU=Min(LMAX,XCU+1) : KY=-1 : End If 
  165.          If A$>=" " and KY>0
  166.             If XCU<LMAX
  167.                ED$=Left$(ED$,XCU)+A$+Mid$(ED$,XCU+1)
  168.                If Len(ED$)>LMAX : ED$=ED$ : End If 
  169.                XCU=Min(LMAX,XCU+1)
  170.             End If 
  171.          End If 
  172.       Loop 
  173.       ED$(ACT+PY)=Left$(ED$(ACT+PY),8)+ED$
  174.       Doke Varptr(ED$(ACT+PY)),FLAG
  175.       NNN=ACT : ACT=0 : Gosub ST_PRINT
  176.    Loop 
  177.    '
  178.    ' Put back in strings
  179.    '
  180.    Paper 1 : Wind Close : Paper 1 : Pen 2 : Clw 
  181.    NN=1
  182.    Return 
  183.    '
  184.    '------------------- 
  185.    ' Print ALL strings  
  186.    '------------------- 
  187.    ALL_PRINT:
  188. Print "**********" : Wait Key 
  189.    For NNN=1 To LED
  190.         Gosub ST_PRINT_ALL
  191. '       If NNN<=THE_LINES
  192.          Set Zone NNN,X Graphic(0),Y Graphic(NNN-1) To X Graphic(66),Y Graphic(NNN-1)+8
  193. '      End If  
  194.    Next 
  195.    Return 
  196.    '------------------
  197.    ' Print ONE string 
  198.    '------------------
  199.    ST_PRINT:
  200.    Curs Off 
  201.    If NNN=ACT
  202.       Inverse On 
  203.    Else 
  204.       Inverse Off 
  205.    End If 
  206. '   If NNN<=THE_LINES
  207.     Locate 0,NNN-1 : Print Chr$(7); Using "###";NNN+PY;"-";Mid$(ED$(PY+NNN),9);
  208. ''' Locate 0,NNN-1 : Print Chr$(7); Using "###";NNN+PY;"-";ED$(PY+NNN) 
  209. '   End If 
  210.    Return 
  211.    '------------------
  212.    ' Print ONE string 
  213.    '------------------
  214.    ST_PRINT_ALL:
  215.    Curs Off 
  216.    If NNN=ACT
  217.       Inverse On 
  218.    Else 
  219.       Inverse Off 
  220.    End If 
  221. '   If NNN<=THE_LINES
  222. ''' Locate 0,NNN-1 : Print Chr$(7); Using "###";NNN+PY;"-";Mid$(ED$(PY+NNN),9);
  223.     Locate 0,NNN-1 : Print Chr$(7); Using "###";NNN+PY;"-";ED$(PY+NNN)
  224. '   End If 
  225.    Return 
  226. '========================================================================
  227. '
  228. OPEN_FILES:
  229. '
  230. 'open header file
  231. '
  232. FILNAM$=FILENAME$
  233. Open Random 1,FILNAM$
  234. Field 1,30 As DBNAME$,6 As DBUSE$,6 As DBDEL$,2 As SYSSEARCH$,8 As CREATEDATE$,6 As COUNT$,6 As MENU1PW$,6 As MENU2PW$,6 As MENU3PW$,6 As MENU4PW$,6 As MENU5PW$,6 As IDXMAX$,2 As FLD_USE$,8 As DBM_VERSION$
  235. If NEW_DB$="Y"
  236.    DBUSE$="000000" : DBDEL$="000000" : IDXMAX$="000000"
  237.    DBNAME$=THE_NAME$
  238.    FLD_USE$=Str$(REC_COUNT)
  239.    SYSSEARCH$="1" : CREATEDATE$="12/10/90" : COUNT$="1" : DBM_VERSION$="2.0(100)"
  240.    Put 1,1
  241. End If 
  242. Get 1,1
  243. '
  244. 'open field file 
  245. '
  246. FILNAM$=FILENAME$+"F"
  247. Open Random 2,FILNAM$
  248. Field 2,20 As FLDN$,3 As FLDL$,10 As FLRPW$,10 As FLWPW$,21 As FLFILLER$
  249. For LP=1 To 50
  250.    Get 2,LP
  251.    DBFN$(LP)=FLDN$
  252.    DBFL$(LP)=FLDL$
  253.    DBRPW$(LP)=FLRPW$
  254.    DBWPW$(LP)=FLWPW$
  255. Next LP
  256. For LP=1 To 50
  257.    If DBFL$(LP)="" : DBFL$(LP)="1" : End If 
  258. Next LP
  259. A=Val(DBFL$(1))
  260. B=Val(DBFL$(2))
  261. C=Val(DBFL$(3))
  262. D=Val(DBFL$(4))
  263. E=Val(DBFL$(5))
  264. F=Val(DBFL$(6))
  265. G=Val(DBFL$(7))
  266. H=Val(DBFL$(8))
  267. I=Val(DBFL$(9))
  268. J=Val(DBFL$(10))
  269. K=Val(DBFL$(11))
  270. L=Val(DBFL$(12))
  271. M=Val(DBFL$(13))
  272. N=Val(DBFL$(14))
  273. O=Val(DBFL$(15))
  274. P=Val(DBFL$(16))
  275. Q=Val(DBFL$(17))
  276. R=Val(DBFL$(18))
  277. S=Val(DBFL$(19))
  278. T=Val(DBFL$(20))
  279. '
  280. ' open data file 
  281. '
  282. FILNAM$=FILENAME$+"D"
  283. Open Random 3,FILNAM$
  284. Field 3,A As A$,B As B$,C As C$,D As D$,E As E$,F As F$,G As G$,H As H$,I As I$,J As J$,K As K$,L As L$,M As M$,N As N$,O As O$,P As P$,Q As Q$,R As R$,S As S$,T As T$
  285. '
  286. 'Open Index file 
  287. '
  288. If Val(SYSSEARCH$)=1 : STORE$=A$ : STORE_VALUE=A : End If 
  289. If Val(SYSSEARCH$)=2 : STORE$=B$ : STORE_VALUE=B : End If 
  290. If Val(SYSSEARCH$)=3 : STORE$=C$ : STORE_VALUE=C : End If 
  291. If Val(SYSSEARCH$)=4 : STORE$=D$ : STORE_VALUE=D : End If 
  292. If Val(SYSSEARCH$)=5 : STORE$=E$ : STORE_VALUE=E : End If 
  293. If Val(SYSSEARCH$)=6 : STORE$=F$ : STORE_VALUE=F : End If 
  294. If Val(SYSSEARCH$)=7 : STORE$=G$ : STORE_VALUE=G : End If 
  295. If Val(SYSSEARCH$)=8 : STORE$=H$ : STORE_VALUE=H : End If 
  296. If Val(SYSSEARCH$)=9 : STORE$=I$ : STORE_VALUE=I : End If 
  297. If Val(SYSSEARCH$)=10 : STORE$=J$ : STORE_VALUE=J : End If 
  298. If Val(SYSSEARCH$)=11 : STORE$=K$ : STORE_VALUE=K : End If 
  299. If Val(SYSSEARCH$)=12 : STORE$=L$ : STORE_VALUE=L : End If 
  300. If Val(SYSSEARCH$)=13 : STORE$=M$ : STORE_VALUE=M : End If 
  301. If Val(SYSSEARCH$)=14 : STORE$=N$ : STORE_VALUE=N : End If 
  302. If Val(SYSSEARCH$)=15 : STORE$=O$ : STORE_VALUE=O : End If 
  303. If Val(SYSSEARCH$)=16 : STORE$=P$ : STORE_VALUE=P : End If 
  304. If Val(SYSSEARCH$)=17 : STORE$=Q$ : STORE_VALUE=Q : End If 
  305. If Val(SYSSEARCH$)=18 : STORE$=R$ : STORE_VALUE=R : End If 
  306. If Val(SYSSEARCH$)=19 : STORE$=S$ : STORE_VALUE=S : End If 
  307. If Val(SYSSEARCH$)=20 : STORE$=T$ : STORE_VALUE=T : End If 
  308. If Val(SYSSEARCH$)<1 or Val(SYSSEARCH$)>20 : STORE$=A$ : STORE_VALUE=A : End If 
  309. FILNAM$=FILENAME$+"I"
  310. Open Random 4,FILNAM$
  311. Field 4,6 As RECIDX$,STORE_VALUE As AIDX$
  312. '
  313. ' open and write to chain file 
  314. '
  315. Open Out 9,"RAM:DBMCHAIN.DAT"
  316. Print #9,FILENAME$
  317. Close 9
  318. '
  319. Return 
  320. '======================================================================= 
  321. Procedure ARROW[X,Y,SX,SY,S,ZON]
  322.    Set Paint 0
  323.    Ink 2 : Set Paint 3
  324.    For N=0 To S-1
  325.       Polyline X-SX+N,Y+SY To X,Y-SY To X+SX-N,Y+SY
  326.    Next 
  327.    SX=Abs(SX) : SY=Abs(SY)
  328.    Set Zone ZON,X-SX,Y-SY To X+SX,Y+SY
  329. End Proc
  330. Procedure CASE[X,Y,SX,SY,S,ZON]
  331.    Set Paint 0
  332.    Ink 2 : Set Paint 3
  333.    For N=0 To S-1
  334.       Box X-SX+N,Y-SY+N To X+SX-N,Y+SY-N
  335.    Next 
  336.    Set Zone ZON,X-SX,Y-SY To X+SX,Y+SY
  337. End Proc
  338. Procedure VER_TEXT[A$,X,Y]
  339.    For N=1 To Len(A$)
  340.       Locate X,Y+N-1
  341.       Print Mid$(A$,N,1);
  342.    Next 
  343. End Proc
  344. Procedure ALERT[A$]
  345.    W=Windon : Window 0
  346.    Centre At(,23)+Space$(78)
  347.    Centre At(,23)+A$
  348.    Window W
  349. End Proc
  350. '------------------------------------------------
  351. '
  352. EROR:
  353. Cls 
  354. Print "ERROR! Return to main program - C/R to Recover."
  355. Wait Key 
  356. If Exist("RAM:DBMLINK.DAT") Then Kill "RAM:DBMLINK.DAT"
  357. '
  358. EX_PROG:
  359. Print At(1,23);"Loading Menu, Please Wait....."
  360. Close 
  361. Run CHAIN_PROG$