home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 8 / CDASC08.ISO / VRAC / USER2AS2.ZIP / USER2ASC.BAS < prev    next >
Encoding:
BASIC Source File  |  1993-07-02  |  10.4 KB  |  304 lines
  1. '+--------------------------[ User2Asc Ver 0.91ß]----------------------------+
  2. '|  Written By Gary Meeker 06/13/93                        Updated 07/02/93  |
  3. '|  SYSOP: SHARP Technical Support Line BBS               Lawrenceville, GA  |
  4. '|         (404) 962-1788                          300-14400 Baud. 24 Hours  |
  5. '+---------------------------------------------------------------------------+
  6. 'V0.90ß 06/13/93 - Initial Beta Release
  7. 'V0.91ß 07/02/93 - Rewrote for new PCBTYPES.INC File
  8. '                  Added Command line parameter for Range of Users
  9.  
  10. DEFINT A-Z
  11.  
  12. '   QuickPack Declarations
  13. DECLARE FUNCTION QInstrB% (Start%, Source$, Srch$)
  14. DECLARE FUNCTION QPStrI$ (IntValue%)
  15.  
  16. '   PDQ Declarations
  17. DECLARE FUNCTION ExeName$ ()
  18. DECLARE FUNCTION PDQParse$ (Work$)
  19. DECLARE FUNCTION PDQValI% (Number$)
  20. DECLARE FUNCTION PDQValL& (Number$)
  21. DECLARE FUNCTION WaitKey2%()                                    'MyOwn
  22. DECLARE SUB CritErrOff ()
  23. DECLARE SUB CritErrOn ()
  24. DECLARE SUB PDQRestore ()
  25. DECLARE SUB SetDelimitChar (Char)
  26.  
  27. '   ProBas Declarations
  28.  
  29. '   Myown Declarations
  30. DECLARE FUNCTION EndString(Temp$, EndCh$)
  31. DECLARE FUNCTION ExistFile% (FileName$)
  32. DECLARE FUNCTION FindLastCh(St$, BYVAL Ch)
  33. DECLARE FUNCTION MidStr(St$, BYVAL Pointer)
  34. DECLARE FUNCTION UnSignedL& (BYVAL X%)
  35. DECLARE FUNCTION UnSignedI% (BYVAL X&)
  36. DECLARE SUB DelChar (Target$, Position, Char$)
  37. DECLARE SUB INC ALIAS "_inc" (IntVar%)
  38. DECLARE SUB INC2 ALIAS "_incL" (LongVar&)
  39. DECLARE SUB InsChar (Target$, Position, Char$)
  40.  
  41. '   Local Declarations
  42. DECLARE FUNCTION EndChar$(St$, EndCh$)
  43. DECLARE FUNCTION MakeExt$(St$, Ext$)
  44. DECLARE SUB Check4File(FileName$, Ercd, ErrMsg)
  45. DECLARE SUB GetParameter(Parameter$, Flag)
  46.  
  47. ' $INCLUDE: 'PCBTYPES.INC'
  48.  
  49. TYPE AppsRecord
  50.    Offset AS LONG
  51.    Typ AS INTEGER
  52. END TYPE
  53.  
  54. DIM SHARED  None, TRUE, FALSE
  55. DIM SHARED  Users AS UsersRecord, UsersInf AS UsersInfRecord, _
  56.             UsersInfHdr AS UsersInfHdrRecord, UsersApp AS UsersAppRecord
  57. DIM SHARED  Alias2 AS STRING * 25, Address AS AddressRecord, _
  58.             Verify AS STRING * 25, Password AS PasswordRecord
  59. DIM SHARED  FirstName AS STRING * 25, LastName AS STRING * 25, _
  60.             SubDate AS STRING * 8, ExpLev AS STRING * 3, SecLev AS STRING * 3,_
  61.             BDPhone AS STRING * 13, HVPhone AS STRING * 13, _
  62.             LastOnDate AS STRING * 8, LastOnTime AS STRING * 5, _
  63.             TimesOn AS STRING * 6
  64.  
  65. FALSE = 0 : TRUE = -1 : None = -1
  66.  
  67. ' Set up shared variables for Check4File
  68. DIM SHARED ComDir$, ExeDir$, PCBDATDir$, PCBDir$
  69.  
  70. PRINT "User2Asc Ver 0.91ß - Copyright 1993 Gary Meeker"
  71.  
  72. Q$ = CHR$(34) : Q2$ = Q$ + "," + Q$
  73.  
  74. UserLen   = LEN(Users)
  75.  
  76. CritErrOff                     ' Stop nasty DOS/SHARE Errors
  77.  
  78. SetDelimitChar 32
  79.  
  80. ' Get command line
  81. C$ = UCASE$(COMMAND$)
  82.  
  83. ' Parse possible command line arguments
  84. GetParameter "/R:", Dummy : Range$ = Value$
  85. ComDir$ = EndChar$(PDQParse$(C$), "\")
  86.  
  87. ' Get Environment variables for Check4File
  88. Program$ = ExeName$
  89. ExeDir$ = LEFT$(Program$, FindLastCh(Program$, 92))
  90. PCBDir$ = EndChar$(ENVIRON$("PCBDRIVE") + ENVIRON$("PCBDIR"), "\")
  91. PCBDATDir$ = ENVIRON$("PCBDAT")
  92. PCBDATDir$ = LEFT$(PCBDATDir$, FindLastCh(PCBDATDir$, 92))
  93. PCBDAT$ = "PCBOARD.DAT"
  94. Ercd = FALSE
  95.  
  96. Check4File PCBDAT$, Ercd, TRUE
  97. IF Ercd GOTO ErrorEnd
  98.  
  99. PRINT #255, "Reading "; PCBDAT$
  100. OPEN PCBDAT$ FOR INPUT ACCESS READ SHARED AS #1     '    Open it
  101.    FOR X = 1 TO 27
  102.       LINE INPUT #1, A$       ' scan past what we don't need
  103.    NEXT X
  104.    LINE INPUT #1, USERSIndexPath$  ' Location of USERS File Index Files   28
  105.    LINE INPUT #1, UserFile$        ' Loc/Name of Users File               29
  106.    FOR X = 1 TO 150
  107.       LINE INPUT #1, A$            ' scan past some more lines
  108.    NEXT X
  109.    LINE INPUT #1, UsersInfFile$     ' Name and location of USERS.INF file 180
  110. CLOSE                                   ' got all we need
  111.  
  112. PRINT #255, "Reading "; UsersInfFile$
  113. OPEN UsersInfFile$ FOR BINARY ACCESS READ SHARED AS #1
  114.    GET #1, 1, UsersInfhdr
  115.    NumofApps& = UnSignedL&(UsersInfhdr.NumofApps)
  116.    HeaderSize& = NumofApps& * LEN(UsersApp) + LEN(UsersInfhdr) + 1&
  117.    DIM Apps(UsersInfhdr.NumofApps) AS AppsRecord
  118.    FOR X = 1 TO UsersInfhdr.NumofApps
  119.      GET #1, , UsersApp
  120.      Apps(X).Offset& = UsersApp.Offset&
  121.      SELECT CASE RTRIM$(UsersApp.AppName$)
  122.         CASE "PCBALIAS"
  123.            AliasPSA = TRUE
  124.            Apps(X).Typ = 1
  125.            PRINT "Alias Support Found"
  126.         CASE "PCBADDRESS"
  127.            AddressPSA = TRUE
  128.            Apps(X).Typ = 2
  129.            PRINT "Address Support Found"
  130.         CASE "PCBVERIFY"
  131.            VerifyPSA = TRUE
  132.            Apps(X).Typ = 3
  133.            PRINT "Verify Support Found"
  134.         CASE "PCBPASSWORD"
  135.            PasswordPSA = TRUE
  136.            Apps(X).Typ = 4
  137.            PRINT "Password Support Found"
  138.         CASE "PCBNOTES"
  139.            NotesPSA = TRUE
  140.            Apps(X).Typ = 5
  141.            PRINT "Notes Support Found"
  142.         CASE "PCBSTATS"
  143.            StatsPSA = TRUE
  144.            Apps(X).Typ = 6
  145.            PRINT "Statistics Support Found"
  146. '       CASE ELSE
  147. '          PRINT "Skipping "; UsersApp.AppName$
  148.      END SELECT
  149.    NEXT X
  150. CLOSE #1
  151.  
  152.  
  153. UserAscFile$ = MakeExt(UserFile$, "ASC")
  154. PRINT #255, "Creating "; UserASCFile$;
  155. OPEN UserFile$ FOR RANDOM ACCESS READ SHARED AS #1 LEN = UserLen
  156. OPEN UsersInfFile$ FOR BINARY ACCESS READ SHARED AS #2
  157. OPEN UserAscFile$ FOR OUTPUT ACCESS WRITE SHARED AS #3
  158.    Recs& = LOF(1) \ UserLen
  159.    Handle = FILEATTR(2,2)
  160.    SetDelimitChar 44        ' Look for "," in Range
  161.    PDQRestore
  162.    Rec& = PDQValL&(PDQParse(Range$))
  163.    IF Rec& < 1 THEN Rec& = 1
  164.    EndRec& = PDQValL&(PDQParse(Range$))
  165.    IF (EndRec& < 1) OR (EndRec& > Recs&) THEN EndRec& = Recs&
  166.    PRINT #255, "  (Records:"; Rec&; "to"; STR$(EndRec&); ")"
  167.    DO While Rec& <= EndRec&
  168.       GET #1, Rec&, Users
  169.       Pointer& = HeaderSize& + (Users.UsersInfPointer& - 1) * UsersInfhdr.TotalRecSize&
  170.       GET #2, Pointer&, UsersInf
  171.       FOR X = 1 TO UsersInfhdr.NumofApps
  172.         SELECT CASE Apps(X).Typ
  173.            CASE 1           ' Alias
  174.               GET #2, Pointer& + Apps(X).Offset&, Alias2
  175.            CASE 2           ' Address
  176.               GET #2, Pointer& + Apps(X).Offset&, Address
  177.            CASE 3           ' Verify
  178.               GET #2, Pointer& + Apps(X).Offset&, Verify
  179.            CASE 4           ' Password
  180.               GET #2, Pointer& + Apps(X).Offset&, Password
  181.            CASE 5           ' Notes
  182.            CASE 6           ' Stats
  183.         END SELECT
  184.       NEXT X
  185.       X = QInstrB(-1, RTRIM$(Users.UserName$), " ")
  186.       IF X THEN
  187.          LSET FirstName$ = LEFT$(Users.UserName$, X - 1)
  188.          LSET LastName$  = MID$(Users.UserName$, X + 1)
  189.       ELSE
  190.          LSET FirstName$ = ""
  191.          LSET LastName$  = Users.UserName$
  192.       END IF
  193.       PRINT #3, Q$; LastName$; Q2$; FirstName$; Q2$; Alias2.UserName$; Q2$;
  194.       PRINT #3, Address.Street1$; Q2$; Address.Street2$; Q2$; _
  195.                 Address.City$; Q2$; Address.State$; Q2$; Address.Zip$; Q2$;_
  196.                 Address.Country$; Q2$;
  197.       RSET BDPhone$ = RTRIM$(Users.BusDataPhone$)
  198.       RSET HVPhone$ = RTRIM$(Users.HomeVoicePhone$)
  199.       LSET SubDate$ = Users.RegExpDate$
  200.       InsChar SubDate$, 3, "-"
  201.       InsChar SubDate$, 6, "-"
  202.       RSET Seclev$ = QPStrI$(ASC(Users.SecLevel$))
  203.       RSET Explev$ = QPStrI$(ASC(Users.ExpSecLevel$))
  204.       LSET LastOnDate$ = Users.LastOnDate$
  205.       InsChar LastOnDate$, 3, "-"
  206.       InsChar LastOnDate$, 6, "-"
  207.       RSET TimesOn$ = QPStrI$(Users.NumTimesOn)
  208.       PRINT #3, BDPhone$; Q2$; HVPhone$; Q2$; Users.UserComment$; Q2$; _
  209.                 Users.SysopComment$; Q2$; SubDate$; Q2$; ExpLev$; Q2$; _
  210.                 SecLev$; Q2$; Users.Password$; Q2$;
  211.       PRINT #3, Password.Previous1$; Q2$; Password.Previous2$; Q2$; _
  212.                 Password.Previous3$; Q2$; Verify.St$; Q2$;
  213.       PRINT #3, TimesOn$; Q2$; LastOnDate$; Q2$; Users.LastOnTime$; Q$
  214.       Inc2 Rec&
  215.    LOOP
  216. CLOSE #2
  217. CLOSE #1
  218.  
  219. Ercd = FALSE
  220.  
  221. ErrorEnd:
  222. IF Ercd THEN
  223.   PRINT #255, "Press any key to Terminate"
  224.   Ke = WaitKey2
  225. END IF
  226.  
  227. ExitProgram:
  228.  
  229. CritErron
  230. END
  231.  
  232. '-----------------------------------------------------------------------------
  233. ' FUNCTION / SUB Procedures
  234. '-----------------------------------------------------------------------------
  235.  
  236. FUNCTION EndChar$(St$, EndCh$) STATIC
  237.    Temp$ = RTRIM$(ST$)
  238.    IF EndString(Temp$, EndCh$) THEN
  239.       EndChar$ = Temp$
  240.    ELSE
  241.       EndChar$ = Temp$ + EndCh$
  242.    END IF
  243. END FUNCTION
  244.  
  245. FUNCTION MakeExt$(St$, Ext$) STATIC
  246.    ExtPos = FindLastCh(St$, 46)
  247.    IF ExtPos THEN
  248.       MakeExt$ = LEFT$(St$, ExtPos) + Ext$
  249.    ELSE
  250.       MakeExt$ = RTRIM$(St$) + "." + Ext$
  251.    END IF
  252. END FUNCTION
  253.  
  254. SUB Check4File(FileName$, Ercd, ErrMsg) STATIC
  255.    IF ExistFile(ComDir$ + FileName$) THEN
  256.       FileName$ = ComDir$ + Filename$
  257.    ELSEIF ExistFile(FileName$) THEN
  258.       EXIT SUB
  259.    ELSEIF ExistFile(PCBDATDir$ + FileName$) THEN
  260.       FileName$ = PCBDATDir$ + FileName$
  261.    ELSEIF ExistFile(PCBDir$ + FileName$) THEN
  262.       FileName$ = PCBDir$ + Filename$
  263.    ELSEIF ExistFile(ExeDir$ + FileName$) THEN
  264.       FileName$ = ExeDir$ + Filename$
  265.    ELSE
  266.       IF ErrMsg THEN
  267.          PRINT #255, CHR$(34); FileName$; CHR$(34); " not Found!"
  268.          PRINT #255, ""
  269.       END IF
  270.       Ercd = TRUE
  271.    END IF
  272. END SUB
  273.  
  274. SUB GetParameter(Parameter$, Par) STATIC
  275.    SHARED C$, Value$
  276.    StrLen = LEN(Parameter$)
  277.    Flag = INSTR(C$, Parameter$)
  278.    IF Flag THEN                                   ' Was Parameter present?
  279.       IF MidStr(Parameter$, StrLen) = 58 THEN     ' Yes, Is it an Optional? ':'
  280.          EndName = INSTR(Flag, C$, " ")           '      Yes, Find End
  281.          IF EndName = 0 THEN                      '
  282.             EndName = LEN(C$) + 1                 '      Must be end of Line
  283.          END IF                                   '
  284.          Temp = EndName - Flag - StrLen           '      This is the length
  285.          Value$ = MID$(C$, Flag + StrLen, Temp)   ' So we can return this
  286.          Par = PDQValI(Value$)                    '
  287.       ELSE
  288.          Temp = 0                                 ' No, so zero length
  289.          Par = -1
  290.       END IF
  291.       DelChar C$, Flag, SPACE$(StrLen + Temp)     ' delete it all
  292.    END IF
  293. END SUB
  294.  
  295. 'This file was last compiled with:
  296. 'BC SCANUSER.BAS  /o /s /ah;
  297. 'LINK SCANUSER+
  298. '     C:\QB\LIB\_NOERROR C:\QB\LIB\_NOFIELD C:\QB\LIB\_NOREAD C:\QB\LIB\_NOVAL+
  299. '     /ex /nod /noe /packcode /far
  300. '
  301. '     nul
  302. '     C:\QB\LIB\SCREEN C:\QB\LIB\MYOWN C:\QB\LIB\QPPRO C:\QB\LIB\PDQFP
  303. '
  304.