home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / BASIC / IMB9005.ZIP / DIR_READ.BAS next >
Encoding:
BASIC Source File  |  1990-05-01  |  4.3 KB  |  162 lines
  1. DECLARE FUNCTION RStr$ (X%, LX%)
  2. DECLARE FUNCTION FmtTime$ (T%)
  3. DECLARE FUNCTION FmtDate$ (FDate%)
  4. DECLARE FUNCTION FindFirst% (Attr%, FIleName$, DEntry AS ANY)
  5. DECLARE FUNCTION FindNext% (DEntry AS ANY)
  6. DECLARE SUB PrintDirEntry (DR AS ANY, FindStatus%)
  7. DECLARE SUB SetDTA (DTA AS ANY)
  8. DECLARE SUB TransferDTA2DIR (DEntry AS ANY)
  9.  
  10. DEFINT A-Z
  11.  
  12. 'Microsoft BASIC module to read directory entries
  13. 'PROGRAM - DIR_READ.BAS
  14. 'BASIC Version 7.0 users should change the next
  15. 'line to use the QBX.BI file instead of QB.BI
  16. '$INCLUDE: 'QB.BI'
  17. TYPE DataTransferArea
  18.     Reserved1   AS STRING * 21
  19.     Attribute   AS STRING * 1
  20.     FileTime    AS INTEGER
  21.     FileDate    AS INTEGER
  22.     FileSize    AS LONG
  23.     FIleName    AS STRING * 13
  24. END TYPE
  25.  
  26. TYPE DirectoryRecord
  27.     FIleName    AS STRING * 13
  28.     FileSize    AS LONG
  29.     FileDate    AS INTEGER
  30.     FileTime    AS INTEGER
  31.     FileAttb    AS INTEGER
  32. END TYPE
  33.  
  34. DIM SHARED InRegsX AS RegTypeX
  35. DIM SHARED OutRegsX AS RegTypeX
  36. DIM SHARED DTA AS DataTransferArea
  37. DIM DirEntry AS DirectoryRecord
  38.   
  39.     CLS
  40.     INPUT "Enter file specification: "; filespec$
  41.     CALL SetDTA(DTA)
  42.   
  43.     FindStatus = FindFirst(0, filespec$, DirEntry)
  44.     CALL PrintDirEntry(DirEntry, FindStatus)
  45.     FindStatus = FindNext(DirEntry)
  46.  
  47.   'IF FindStatus <> 0 then there are no more files
  48.   '   or no match was found or no prev call to
  49.   '   FindFirst
  50.     WHILE FindStatus = 0
  51.         CALL PrintDirEntry(DirEntry, FindStatus)
  52.         FindStatus = FindNext(DirEntry)
  53.         CALL SetDTA(DTA)
  54.     WEND
  55.  
  56. END
  57.  
  58. FUNCTION FindFirst (Attr, FIleName$, DEntry AS DirectoryRecord)
  59.     InRegsX.AX = &H4E00
  60.     InRegsX.CX = Attr
  61.  
  62. ' DOS requires an ASCIIZ string so add CHR$(0)
  63.  
  64.      Spec$ = FIleName$ + CHR$(0)
  65. ' Version 7.0 users change VARSEG to SSEG
  66.      InRegsX.DS = VARSEG(Spec$) ' Load DS:DX with
  67.      InRegsX.DX = SADD(Spec$)   ' address of Spec$
  68.      CALL InterruptX(&H21, InRegsX, OutRegsX)
  69.  
  70. ' The next line sets an error as default condition
  71.  
  72.     FindFirst = OutRegsX.AX
  73.  
  74. ' Check if carry flag is clear in the next line
  75.  
  76.     IF (OutRegsX.Flags AND 1) = 0 THEN
  77.         CALL TransferDTA2DIR(DEntry)
  78.         FindFirst = 0 'Clear error condition setting
  79.     END IF
  80. END FUNCTION
  81.  
  82. FUNCTION FindNext (DEntry AS DirectoryRecord)
  83.    DTA.FIleName = SPACE$(13)
  84.     InRegsX.AX = &H4F00
  85.     CALL InterruptX(&H21, InRegsX, OutRegsX)
  86.     FindNext = OutRegsX.AX
  87.     IF (OutRegsX.Flags AND 1) = 0 THEN
  88.         CALL TransferDTA2DIR(DEntry)
  89.         FindNext = 0
  90.     END IF
  91. END FUNCTION
  92.  
  93. FUNCTION FmtDate$ (FDate)
  94.     Day = FDate AND &H1F
  95.     Month = (FDate AND &H1E0) \ 32
  96.     Year = (FDate AND &HFE00) \ 512 + 1980
  97.     FmtDate$ = RStr$(Month, 2) + "-" + RStr$(Day, 2) + "-" + RStr$(Year, 4)
  98. END FUNCTION
  99.  
  100. FUNCTION FmtTime$ (T%)
  101.     Seconds = (T% AND &H1F) * 2
  102.     Minutes = (T% AND &H7E0) \ 32
  103.   
  104.     Hours = (T% < 0) * (-16) + ((T% AND &H7FFF) \ 2048)
  105.     Abbr$ = " am"
  106.     IF Hours = 12 THEN Abbr$ = " pm"
  107.     IF Hours = 0 THEN Hours = 12
  108.   
  109.     IF Hours > 12 THEN   'Reset to 12 hour clock
  110.         Hours = Hours MOD 12
  111.         Abbr$ = " pm"
  112.     END IF
  113.     FmtTime$ = RStr$(Hours, 2) + ":" + RStr$(Minutes, 2) + ":" + RStr$(Seconds, 2) + Abbr$
  114. END FUNCTION
  115.  
  116. SUB GetDTAAddr (Segment, Offset)  'Subprogram not used but included for your convenience
  117.     InRegsX.AX = &H2F00
  118.     CALL InterruptX(&H21, InRegsX, OutRegsX)
  119.     Segment = OutRegsX.ES   'Return address of DTA
  120.     Offset = OutRegsX.BX    'Segment:Offset format
  121. END SUB
  122.  
  123. SUB PrintDirEntry (DR AS DirectoryRecord, FindStatus)
  124.     FmtStr$ = "\          \  ##,###,###  " + "\        \ \           \  ###"
  125.     IF FindStatus = 0 THEN
  126.         PRINT USING FmtStr$; DR.FIleName; DR.FileSize; FmtDate$(DR.FileDate); FmtTime$(DR.FileTime); DR.FileAttb
  127.     ELSE
  128.         PRINT "Error on file lookup"
  129.         SELECT CASE FindStatus
  130.             CASE 2
  131.                 PRINT "File not found"
  132.             CASE 3
  133.                 PRINT "Path not found"
  134.             CASE 18
  135.                 PRINT "Match not found"
  136.             CASE ELSE
  137.                 PRINT "Unknown error #"; FindStatus
  138.         END SELECT
  139.     END IF
  140. END SUB
  141.  
  142. FUNCTION RStr$ (X%, LX%)
  143.     X$ = STR$(X%)
  144.     RStr$ = RIGHT$("00000" + RIGHT$(X$, LEN(X$) - 1), LX%)
  145. END FUNCTION
  146.  
  147. SUB SetDTA (DTA AS DataTransferArea)
  148.     InRegsX.AX = &H1A00
  149.     InRegsX.DS = VARSEG(DTA)
  150.     InRegsX.DX = VARPTR(DTA)   'Use for records
  151.     CALL InterruptX(&H21, InRegsX, OutRegsX)
  152. END SUB
  153.  
  154. SUB TransferDTA2DIR (DEntry AS DirectoryRecord)
  155.     DEntry.FIleName = DTA.FIleName
  156.     DEntry.FileSize = DTA.FileSize
  157.     DEntry.FileDate = DTA.FileDate
  158.     DEntry.FileTime = DTA.FileTime
  159.     DEntry.FileAttb = ASC(DTA.Attribute)
  160. END SUB
  161.  
  162.