'***** More Useful subs and functions ******
'=======================================================================|
' Also see Fileops functions: |
' QUOTE - Returns a quoted string |
' STRIPPATH - Returns file path (without file name) |
' STIPFILENAME - Returns file name (without path) |
' STRIPFILEEXT - Returns file extension (like ".exe", ".html" etc.) |
' FILENAMENOEXT - Returns file name without extension |
' FULLPATHNOEXT - Returns full path without file extension |
' BROWSEFORFOLDERS : Returns the selected folder |
' BROWSEFORFILE : Uses opendialog, returns file name |
'=======================================================================|
$ESCAPECHARS ON
'ChangeFileExt:
'Returns: String
'Parameters:
'FileName (String): Name of file with old extention
'NewExt (String): New extention. This must include the leading ".".
'Information:
'Author: Taj Morton
'Email: tmorton at linuxmail dot org.
'License: Public Domain
'Description:
'Changes the extention of FileName to NewExt. For example:
'ChangeFileExt("File.bas", ".inc")
'returns File.inc. This function does not delete the old string,
'instead, it simply returns a new one with the extention.
'You must include the leading "." for it to be added, as it is not
'done by the function.
FUNCTION ChangeFileExt(FileName AS STRING , NewExt AS STRING) AS STRING
DIM Returns AS STRING
DIM CurrentExt AS STRING
DIM CurrentExtLoc AS INTEGER
DIM FileNoExt AS STRING
CurrentExtLoc = RInStr(FileName , ".")
CurrentExt = MID$(FileName , CurrentExtLoc , LEN(FileName))
FileNoExt = DELETE$(FileName , CurrentExtLoc , LEN(FileName))
Result = INSERT$(NewExt , FileNoExt , LEN(FileName))
ChangeFileExt = Result
END FUNCTION
'ExtractFileName:
'Returns: String
'Parameters:
'FileName (String): File with full path
'Information:
'Author: Taj Morton
'Email: tmorton at linuxmail dot org.
'License: Public Domain
'Description:
'ExtractFileName takes a file name with a path and returns only
'the file name. For example:
'ExtractFileName("C:\\Program Files\\AFile.bas")
'returns AFile.bas. You can use either two back-slashes or a single
'forward slash (/) for folder seperators.
'Both forward and back-slashes are supported by Windows.
'The back-slash takes procedure over the forward slash.
'Note that ExtractFileName does _not_ check the validity of the path passed.
'You must check yourself.
FUNCTION ExtractFileName(FileName AS STRING) AS STRING
DIM Length AS INTEGER
DIM Result AS STRING
Length = RInStr(FileName , "\\") OR RInStr(FileName , "/")
Result = MID$(FileName , Length + 1 , LEN(FileName) - Length + 1)
ExtractFileName = Result
END FUNCTION
'ExtractFilePath
'Returns: String
'Parameters:
'FileName (String): File with full path
'Information:
'Author: Taj Morton
'Email: tmorton at linuxmail dot org.
'License: Public Domain
'Description:
'ExtractFilePath takes string with full path and returns a string
'with only the path. For example:
'ExtractFilePath("C:\\Program Files\\AProgram.bas")
'returns C:\Program Files (the \\'s are for RQ and back-slashes).
'ExtractFilePath also takes forward-slashes (/). Window's supports
'these as well.
'The back-slash takes procedure over the forward slash.
'Note that ExtractFilePath does _not_ test the validity
'of the passed name. You must check it yourself. Even if the name is
'invalid, the path will be returned. For example, if C:/ProgramErrorFiles/AFile.txt
'is passed, C:/ProgramErrorFiles will be returned.
FUNCTION ExtractFilePath(FileName AS STRING) AS STRING
DIM Length AS INTEGER
DIM Result AS STRING
Length = RInStr(FileName , "\\") OR RInStr(FileName , "/")
Result = MID$(FileName , 0 , Length)
ExtractFilePath = Result
END FUNCTION
'ChangeFileName
'Returns: String
'Parameters:
'FileName (String): File with full path
'NewName (String): Text that will replace old file name
'Information:
'Author: Taj Morton
'Email: tmorton at linuxmail dot org.
'License: Public Domain
'Description:
'ChangeFileName takes a file name with full path and file and a new name.
'It replaces the current filename (in FileName) and replaces it with NewName.
'ChangeFileName does not actually change FileName, instead it returns a new
'string which contains the new name.
'Note that ChangeFileName does not check the validity of FileName
'or the new result. You must do it yourself (if you want). ChangeFileName
'takes both the back-slash and forward slash to serperate folder and file names.
'You can use either \\ or /. Both are supported by Windows.
'The back-slash takes procedure over the forward slash.
FUNCTION ChangeFileName(FileName AS STRING , NewName AS STRING) AS STRING
DIM FileNameLoc AS INTEGER
DIM Result AS STRING
DIM PathNoName AS STRING
PathNoName = ExtractFilePath(FileName)
Result = PathNoName + NewName
ChangeFileName = Result
END FUNCTION
'ChangeFilePath
'Returns: String
'Parameters:
'FileName (String): File with full path
'NewPath (String): New path that will replace the path in FileName
'Information:
'Author: Taj Morton
'Email: tmorton at linuxmail dot org.
'License: Public Domain
'Description:
'ChangeFilePath takes FileName and replaces the path with NewPath.
'It does not change FileName to have the new path, instead, it returns
'a string which has the new path. It's up to you to take the correct
'action. Also, old or new path and names' are not checked for validity,
'you must do it yourself.
'You may use either the \\ or the / to seperate your paths. Windows supports
'both.
FUNCTION ChangeFilePath(FileName AS STRING , NewPath AS STRING) AS STRING
DIM Result AS STRING
DIM FileNoPath AS STRING
FileNoPath = ExtractFileName(FileName)
Result = NewPath + FileNoPath
ChangeFilePath = Result
END FUNCTION
$ESCAPECHARS OFF
'-- *****************************************************'
FUNCTION FileSize(FileName AS STRING) AS INTEGER
DIM fileStr AS QFILESTREAM
IF FILEEXISTS(FileName) > 0 THEN
fileStr.Open(FileName , 0)
Result = fileStr.Size
fileStr.Close
ELSE
Result = - 1
END IF
END FUNCTION
'-- *****************************************************'
FUNCTION SaveString(ss$ AS STRING , FileName AS STRING) AS INTEGER
Result = 0
IF FileName = "" THEN SHOWMESSAGE("FUNCTION SaveString. Wrong FileName=" + FileName) :EXIT FUNCTION
DIM fileStr AS QFILESTREAM
fileStr.Open(FileName , 65535) 'fmCreate'
Result = - 1
fileStr.WriteStr(ss$ , LEN(ss$))
fileStr.Close
Result = 1
END FUNCTION
'-- *****************************************************'
FUNCTION SaveStringEx(ss$ AS STRING , FileName AS STRING , mode AS INTEGER) AS INTEGER
'save string SS$ to file FileName.
'Mode=0 - overwrite,
'Mode=1 - append string ss$ to file FileName
'Mode=2 - append crlf+ss$ to file FileName
Result = 0
IF FileName = "" THEN SHOWMESSAGE("FUNCTION SaveString. Wrong FileName=" + FileName) :exit FUNCTION
DIM fileStr AS QFILESTREAM
IF mode = 0 THEN
Result = 0
fileStr.Open(FileName , 65535) 'fmCreate'
Result = - 1
fileStr.WriteStr(ss$ , LEN(ss$))
fileStr.Close
ELSEIF mode = 1 OR mode = 2 THEN
DEFSTR crlf = ""
DEFINT md = 65535 'create new file
IF FILEEXISTS(FileName) THEN 'else append
md = 2 'fmOpenReadWrite
crlf = CHR$(13) + CHR$(10)
'ELSE
'showmessage("FUNCTION SaveString. Can't open File=" + FileName) :exit FUNCTION
END IF
fileStr.Open(FileName , md)
fileStr.Position = fileStr.Size
Result = - 1
IF mode = 1 THEN fileStr.WriteStr(ss$ , LEN(ss$)) ELSE fileStr.WriteStr(crlf + ss$ , LEN(crlf + ss$))
fileStr.Close
ELSE
END IF
Result = 1
END FUNCTION
'-- *****************************************************'
FUNCTION LoadString(FileName AS STRING) AS STRING
DIM fileStr AS QFILESTREAM
Result = "0"
IF fileStr.Open(FileName , 0) THEN ''fmOpenRead
Result = "-1"
Result = fileStr.ReadStr(fileStr.Size)
fileStr.Close
'result=1
END IF
END FUNCTION
'--------- Windows API call for functions below -----------------
$IFNDEF __WIN32API
DECLARE FUNCTION CharToOem LIB "user32" ALIAS "CharToOemA" _
(ByVal lpszSrc AS STRING , ByVal lpszDst AS STRING) AS LONG
DECLARE FUNCTION OemToChar LIB "user32" ALIAS "OemToCharA" _
(ByVal lpszSrc AS STRING , ByVal lpszDst AS STRING) AS LONG
$ENDIF
'-- *****************************************************'
FUNCTION MKSubDir(DirDst$) AS SHORT
'Andrew Shelkovenko dec 2003, jul 2004
'Create DirDst$ directory with full subdir structure
'----------------------------------------------
'print "MKSubDir DirDst$="; DirDst$
Result = 0
DEFSTR DirDst1$ = STRING$(LEN(DirDst$) , "a"), BkSl = "\", SubDirDst$
'CharToOem DirDst$,DirDst1$
DirDst1$ = DirDst$
IF RIGHT$(DirDst1$ , 1) <> BkSl THEN DirDst1$ = DirDst1$ + BkSl
DEFINT z1 = INSTR(DirDst1$ , BkSl)
DEFINT z2 = 0
WHILE z1 > 0
SubDirDst$ = LEFT$(DirDst1$ , z1)
IF DIREXISTS(SubDirDst$) = 0 THEN MKDIR SubDirDst$ : 'print "MKSubDir SubDirDst$=" ,SubDirDst$
z2 = z1 + 1
z1 = INSTR(z2 , DirDst1$ , BkSl)
WEND
Result = 1
END FUNCTION
'-- *****************************************************'
'Andrew Shelkovenko dec 2003
'Copy DirSrc$ directory with full subdir structure and files (by mask$) to DirDst$
'- -----------------------------------'
SUB SubDirCopy(DirSrc$ , DirDst$ , mask$)
DIM FileSrc AS QFILESTREAM
DIM FileDst AS QFILESTREAM
'Index=0
DEFINT NumFiles = 0, nsd1 = 0, nsd2 = 0, i
DEFINT NumDir = 0, adddir, ArrNumDir = 500, ArrNumFil = 500
DEFSTR mask = "*.*", BkSl = "\", SubDirname$, Fn$
DIM SubDir(500) AS STRING
DIM FileNames(500) AS STRING
IF RIGHT$(DirSrc$ , 1) <> BkSl THEN DirSrc$ = DirSrc$ + BkSl
IF RIGHT$(DirDst$ , 1) <> BkSl THEN DirDst$ = DirDst$ + BkSl
SubDir(0) = DirSrc$
sss1:
FOR i = nsd1 TO nsd2 'current level sudirs'
'print "374 SubDir(",i,")=",SubDir(i)
SubDirname$ = DIR$(SubDir(i) + mask , faDirectory)
WHILE SubDirname$ <> ""
IF FileRec.Size = 0 AND SubDirname$ <> "." AND SubDirname$ <> ".." THEN '
INC adddir
INC NumDir 'add subdir'
IF NumDir = ArrNumDir THEN ArrNumDir = ArrNumDir + 300: REDIM SubDir(ArrNumDir) AS STRING
SubDir(NumDir) = SubDir(i) + SubDirname$ + "\"
'print "383 SubDir(", NumDir, ")=",SubDir(NumDir)
ELSE
END IF
SubDirname$ = DIR$
doevents
WEND
'search files in current subdirectory
Fn$ = DIR$(SubDir(i) + mask$ , faAnyFile - faDirectory) ':-)
WHILE Fn$ <> ""
IF Fn$ <> "." AND Fn$ <> ".." THEN 'and FileRec.Size <>0'
INC NumFiles
IF NumFiles = ArrNumFil THEN ArrNumFil = ArrNumFil + 300: REDIM FileNames(ArrNumFil) AS string: 'print "redim FileNames"
FileNames(NumFiles) = SubDir(i) + Fn$
'print "FileNames(",NumFiles,")=" ,FileNames(NumFiles)
ELSE
END IF
Fn$ = DIR$
WEND
NEXT i
IF adddir > 0 THEN
nsd1 = nsd2 + 1
nsd2 = nsd2 + adddir
adddir = 0
GOTO sss1 'repeat with new sub level
ELSE
END IF
'got subdirs list in SubDir(i) array and file list with full path in FileNames(j)
'now create subdirs structure with new path
DEFINT i1
DEFSTR NewSubDir$
FOR i1 = 0 TO i - 1
NewSubDir$ = SubDir(i1) - DirSrc$
NewSubDir$ = DirDst$ + NewSubDir$
MKSubDir(NewSubDir$)
NEXT i1
DEFINT j
DEFSTR NewFileName$
FOR j = 1 TO NumFiles
FileSrc.Open(FileNames(j) , fmOpenRead)
IF FileSrc.Size = 0 THEN FileSrc.close: GOTO nextj1
NewFileName$ = FileNames(j) - DirSrc$
NewFileName$ = DirDst$ + NewFileName$
'print "NewFileName$=" ,NewFileName$
FileDst.Open(NewFileName$ , fmCreate)
FileDst.CopyFrom(FileSrc , 0) '
FileSrc.Close '
FileDst.Close
nextj1:
NEXT j
END SUB
'-- *****************************************************'
FUNCTION fSubDirCopy(DirSrc$ , DirDst$ , mask$) AS LONG '- -----------------------------------'
'Andrew Shelkovenko dec 2003
'Copy DirSrc$ directory with full subdir structure and files (by mask$) to DirDst$
'DiaMsg$="??? ?????ﮮ"
DIM FileSrc AS QFILESTREAM
DIM FileDst AS QFILESTREAM
Result = - 1
'Index=0
DEFINT i, nsd1 = 0, nsd2 = 0, NumFiles = 0, NumDir = 0, addDir, ArrNumDir = 500, ArrNumFil = 500
DEFSTR mask, BkSl = "\", SUBDIRNAME$, NewFileName$, NewFileName1$, DiaMsg$
DIM SubDir(500) AS STRING
DIM FileNames(500) AS STRING
mask = "*.*"
IF RIGHT$(DirSrc$ , 1) <> BkSl THEN DirSrc$ = DirSrc$ + BkSl
'print "DirSrc$="; DirSrc$
IF RIGHT$(DirDst$ , 1) <> BkSl THEN DirDst$ = DirDst$ + BkSl
'print "DirDst$="; DirDst$
SubDir(0) = DirSrc$
sss1:
FOR i = nsd1 TO nsd2 'current level sudirs'
'print "374 SubDir(",i,")=",SubDir(i)
SubDirname$ = DIR$(SubDir(i) + mask , faDirectory)
WHILE SubDirname$ <> ""
IF FileRec.Size = 0 AND SubDirname$ <> "." AND SubDirname$ <> ".." THEN '
INC addDir
INC NumDir 'add subdir'
IF NumDir = ArrNumDir THEN ArrNumDir = ArrNumDir + 300: REDIM SubDir(ArrNumDir) AS string: 'DiaMsg$="?? ????? ?®???४?eg;ਨ "+SubDir(NumDir) 'SubDirname$
SubDir(NumDir) = SubDir(i) + SubDirname$ + "\"
'print "383 SubDir(", NumDir, ")=",SubDir(NumDir)
'DiaMsg$="??????????? "+SubDir(NumDir) 'SubDirname$
ELSE
END IF
SubDirname$ = DIR$
doevents
WEND
'DiaMsg$="????????? " +str$(NumDir)
'search files in current subdirectory
DEFSTR Fn$ = DIR$(SubDir(i) + mask$ , faAnyFile - faDirectory) ':-)
WHILE Fn$ <> ""
IF Fn$ <> "." AND Fn$ <> ".." THEN 'and FileRec.Size <>0'
INC NumFiles
IF NumFiles = ArrNumFil THEN ArrNumFil = ArrNumFil + 300: REDIM FileNames(ArrNumFil) AS string: 'DiaMsg$=str$(NumFiles)
FileNames(NumFiles) = SubDir(i) + Fn$
'print "FileNames(",NumFiles,")=" ,FileNames(NumFiles)
'DiaMsg$="??????? "+FileNames(NumFiles)
ELSE
END IF
Fn$ = DIR$
WEND
NEXT i
Result = - 2
IF adddir > 0 THEN
nsd1 = nsd2 + 1
nsd2 = nsd2 + adddir
adddir = 0
GOTO sss1 'repeat with new sub level
ELSE
END IF
'got subdirs list in SubDir(i) array and file list with full path in FileNames(j)
'now create subdirs structure with new path
'DiaMsg$="????????议. "
DEFINT i1
DEFSTR NewSubDir$
FOR i1 = 0 TO i - 1
NewSubDir$ = SubDir(i1) - DirSrc$
NewSubDir$ = DirDst$ + NewSubDir$
MKSubDir(NewSubDir$)
'DiaMsg$="????????quot;+NewSubDir$
NEXT i1
Result = - 3
'DiaMsg$="???? ??뮮."
DEFINT j
FOR j = 1 TO NumFiles
'DiaMsg$="???? ?????렦quot;+FileNames(j)
'DiaMsg$="Try to open file "+NewFileName$
FileSrc.Open(FileNames(j) , fmOpenRead)
'DiaMsg$="???蠦quot;+FileNames(j) +" ???=" +str$( FileSrc.size)
'print "opened " +FileNames(j)
'print "FileSrc.size=" ,FileSrc.size
IF FileSrc.Size = 0 THEN
FileSrc.close:
'print "zerosize closed " +FileNames(j):
GOTO nextj
END IF
NewFileName1$ = FileNames(j) - DirSrc$
NewFileName$ = DirDst$ + NewFileName1$
'print "NewFileName$=" ,NewFileName$
'DiaMsg$="???? ?????렦quot;+NewFileName1$
'DiaMsg$="Try to create file "+NewFileName$
FileDst.Open(NewFileName$ , fmCreate)
'DiaMsg$="???? ???????렦quot; +FileNames(j) +" ⠦quot;+NewFileName1$
'print "DiaMsg$=" ,DiaMsg$
'DiaMsg$="Try to copy "
FileDst.CopyFrom(FileSrc , 0) '
FileSrc.Close '
FileDst.Close
'DiaMsg$="Copied "+str$(j) + " from "+ str$(NumFiles)+" = "+ NewFileName$
DiaMsg$ = "????????⠦quot; + STR$(j) 'FileNames(j) ' + " ⠦quot; + NewFileName$
nextj:
DOEVENTS
NEXT j
Result = j - 1
'DiaMsg$="???????? ???"+ str$(result) + " ? "+ str$(NumFiles)
END FUNCTION
'-- ***********************************************************************'
FUNCTION DirCopy(DirSrc$ , DirDst$ , mask$) AS LONG
'print "DirCopy mask$=" ,mask$
'print "DirCopy DirDst$=" ,DirDst$
'print "DirCopy DirSrc$=" ,DirSrc$
'Andrew Shelkovenko dec 2003
'Copy files (by mask$) from DirSrc$ to DirDst$
Result = 0
DIM FileSrc AS QFILESTREAM
DIM FileDst AS QFILESTREAM
DEFINT NumFIles
NumFIles = 0
'MKDIR DirDst$
MKSubDir(DirDst$)
IF RIGHT$(DirSrc$ , 1) <> "\" THEN DirSrc$ = DirSrc$ + "\"
IF DIREXISTS(DirDst$) = 0 THEN
SHOWMESSAGE("DirCopy Error: Can't create folder " + DirDst$)
EXIT FUNCTION
END IF
'print "DirCopy DirSrc$+mask$=" ,DirSrc$+mask$
DEFSTR FileName$ = DIR$(DirSrc$ + mask$ , 0) '-- Get first file
'print "DirCopy FileName$=" ,FileName$
WHILE FileName$ <> ""
FileSrc.Open(DirSrc$ + filename$ , fmOpenRead)
FileDst.Open(DirDst$ + "\" + filename$ , fmCreate)
FileDst.CopyFrom(FileSrc , 0)
FileSrc.Close
FileDst.Close
FileName$ = DIR$ '-- Get next file
INC NumFIles
WEND
'print "DirCopy copied= "+str$(NumFIles) +" files
Result = NumFIles
END FUNCTION
'-- ***********************************************************************'
SUB FileCopy(FileSrc$ , FileDst$) '- -----------------------------------'
'Andrew Shelkovenko dec 2003
'Copy FileSrc$ to FileDst$
'if path dest is not exists - create it.
DIM FileSrc AS QFILESTREAM
DIM FileDst AS QFILESTREAM
DEFSTR dr$ = StripPath(FileDst$)
'print "dr$=" ,dr$
'MKDIR dr$ 'StripPath (FileDst$)
IF dr$ <> "" THEN
MKSubDir dr$
IF DIREXISTS(dr$) = 0 THEN SHOWMESSAGE("FileCopy Can't create directory " + dr$) : 'exit sub
END IF
FileSrc.Open(FileSrc$ , fmOpenRead)
FileDst.Open(FileDst$ , fmCreate)
FileDst.CopyFrom(FileSrc , 0)
FileSrc.Close
FileDst.Close
'print "FileCopy (";FileSrc$, FileDst$;") done"
END SUB
'-- ***********************************************************************'
SUB KillFiles(FileName$)
'Andrew Shelkovenko diakin@narod.ru apr 2004
'Kill files in FileName$
'for example KillFiles "C:\BAS\RAPIDQ\tmp\*.tmp"
DEFSTR FName$ = StripPath(FileName$) + DIR$(FileName$ , 0) '-- Get first file
'print " ------------------- FName$=" ,FName$
WHILE StripFileName(FName$) <> ""
KILL FName$
'print "killed FName$=" ,FName$
IF FILEEXISTS(StripPath(FileName$) + FName$) > 0 THEN SHOWMESSAGE("KillFiles Can't kill file " + FName$)
'print "Can't kill file "+FName$
FName$ = StripPath(FileName$) + DIR$ '-- Get next file
WEND
END SUB
'-- *****************************************************'
SUB KillSubDir(DirSrc$ , mask$) '- -----------------------------------'
'print "-- KillSubDir DirSrc$=",DirSrc$
'Andrew Shelkovenko diakin@narod.ru may 2004
'Kill files by mask$ in all subdirs in DirSrc$ directory and kill all empty subdirs and DirSrc$ (if empty)
'So.. if mask$="*.*" then kill DirSrc$ with all subdirs and files
DIM FileSrc AS QFILESTREAM
'Index=0
DEFINT i, nsd1 = 0 , nsd2 = 0, NumFIles = 0, NumDir = 0, adddir,ArrNumDir = 500, ArrNumFil = 500
DEFSTR mask, BkSl = "\", SubDirname$, Fn$
DIM SubDir(500) AS STRING
DIM FileNames(500) AS STRING
mask = "*.*"
IF RIGHT$(DirSrc$ , 1) <> BkSl THEN SubDir(0) = DirSrc$ + BkSl ELSE SubDir(0) = DirSrc$
'print "BkSl=" ,BkSl
'print "SubDir(0)=" ,SubDir(0)
s1:
FOR i = nsd1 TO nsd2 'current level sudirs'
'print "KillSubDir SubDir(",i,")=",SubDir(i)
SubDirname$ = DIR$(SubDir(i) + mask , faDirectory)
'print "-- KillSubDir SubDirname$=",SubDirname$
WHILE SubDirname$ <> ""
IF FileRec.Size = 0 AND SubDirname$ <> "." AND SubDirname$ <> ".." THEN '
INC adddir
INC NumDir 'add subdir'
IF NumDir = ArrNumDir THEN ArrNumDir = ArrNumDir + 300: REDIM SubDir(ArrNumDir) AS STRING
SubDir(NumDir) = SubDir(i) + SubDirname$ + "\"
'print "--KillSubDir SubDir(", NumDir, ")=",SubDir(NumDir)
ELSE
END IF
SubDirname$ = DIR$
doevents
WEND
'search files in current subdirectory
Fn$ = DIR$(SubDir(i) + mask$ , faAnyFile - faDirectory) ':-)
WHILE Fn$ <> ""
IF Fn$ <> "." AND Fn$ <> ".." THEN 'and FileRec.Size <>0'
KILL SubDir(i) + Fn$
'print "-- KillSubDir kill ",SubDir(i)+Fn$
ELSE
END IF
Fn$ = DIR$
WEND
NEXT i
IF adddir > 0 THEN
nsd1 = nsd2 + 1
nsd2 = nsd2 + adddir
adddir = 0
GOTO s1 'repeat with new sub level
ELSE
END IF
DEFINT i1
FOR i1 = i - 1 TO 1 STEP - 1
RMDIR SubDir(i1)
'print "-- KillSubDir RMDIR SubDir(",i1,")=", SubDir(i1)
NEXT i1
END SUB
'-- ***********************************************************************'
SUB io2Rnd(fsrc$ , fdst$)
'--------------------------------
'convert text file with single value strings to binary
'for example
'17.78091
'16.64166
'fsrc$ - source file fdst$ - dest. file
'data type - single
'CONST fmCreate = 65535
'CONST fmOpenRead = 0
'CONST fmOpenWrite = 1
'CONST fmOpenReadWrite = 2
DIM FileSourse AS QFILESTREAM
DIM FileDest AS QFILESTREAM
DEFSNG ValSrc
DEFSTR ValSrc$
FileSourse.Open(fsrc$ , 2) 'fmOpenReadWrite'
FileDest.Open(fdst$ , 65535) 'fmOpenReadWrite'
WHILE NOT FileSourse.EOF
ValSrc$ = FileSourse.ReadLine : 'print "ValSrc$=" ,ValSrc$
ValSrc = VAL(ValSrc$) : 'print "ValSrc=" ,ValSrc
FileDest.Write(ValSrc)
WEND
FileSourse.Close
FileDest.Close
END SUB
'-- ***********************************************************************'
SUB Rnd2io(fsrc$ , fdst$)
'--------------------------------
'convert binary file with single type value data to text file with single type value strings
'i.e
'17.78091
'16.64166
'19.87037
'CONST fmCreate = 65535
'CONST fmOpenRead = 0
'CONST fmOpenWrite = 1
'CONST fmOpenReadWrite = 2
'CONST Num_BYTE = 1
'CONST Num_SHORT = 2
'CONST Num_WORD = 3
'CONST Num_LONG = 4
'CONST Num_DWORD = 5
'CONST Num_SINGLE = 6
'CONST Num_DOUBLE = 8
DIM FileSourse AS QFILESTREAM
DIM FileDest AS QFILESTREAM
DEFSNG ValSrc
DEFSTR ValSrc$
FileSourse.Open(fsrc$ , 2) 'fmOpenReadWrite'
FileDest.Open(fdst$ , 65535) 'fmOpenCreate'
DEFINT ie = FileSourse.Size / 4, i
FOR i = 0 TO ie - 1
ValSrc = FileSourse.ReadNum(6) : 'print "ValSrc=" ,ValSrc
ValSrc$ = STR$(ValSrc) : 'print "ValSrc$=" ,ValSrc$
FileDest.WriteLine(ValSrc$)
NEXT i
FileSourse.Close
FileDest.Close
END SUB
'-- ***********************************************************************'
SUB io2RndPV(fsrc$ , fdst$)
'--------------------------------
'convert text file with single value strings to binary
'for example
'17.78091
'16.64166
'fsrc$ - source file fdst$ - dest. file
'data type - single
'CONST fmCreate = 65535
'CONST fmOpenRead = 0
'CONST fmOpenWrite = 1
'CONST fmOpenReadWrite = 2
DIM FileSourse AS QFILESTREAM
DIM FileDest AS QFILESTREAM
DEFSNG ValSrc
DEFSTR ValSrc$
FileSourse.Open(fsrc$ , 2) 'fmOpenReadWrite'
FileDest.Open(fdst$ , 65535) 'fmOpenReadWrite'
WHILE NOT FileSourse.EOF
ValSrc$ = FileSourse.ReadLine : 'print "ValSrc$=" ,ValSrc$
ValSrc = VAL(ValSrc$) : 'print "ValSrc=" ,ValSrc
FileDest.Write(ValSrc)
WEND
FileSourse.Close
FileDest.Close
END SUB
'-------------------------------------------------------------------'
'-- ***********************************************************************'
FUNCTION ChDirOEM(PathDst$) AS SHORT
'print "ChDirOEM PathDst$=" ,PathDst$
Result = 0
DIM PathDst1$ AS STRING
PathDst1$ = STRING$(LEN(PathDst$) , "a")
CharToOem PathDst$ , PathDst1$
'print "ChDirOEM PathDst$=" ,PathDst$
'print "ChDirOEM PathDst1$=" ,PathDst1$
CHDIR PathDst1$
Result = 1
END FUNCTION
'-------------------------------------------------------------------'
'-- ***********************************************************************'
FUNCTION MkDirOEM(PathDst$) AS SHORT
Result = 0
DIM PathDst1$ AS STRING
'print "MkDirOEM PathDst$=" ,PathDst$
PathDst1$ = STRING$(LEN(PathDst$) , "a")
CharToOem PathDst$ , PathDst1$
'print "MkDirOEM PathDst$=" ,PathDst$
'print "MkDirOEM PathDst1$=" ,PathDst1$
MKDIR PathDst1$
Result = 1
END FUNCTION
'-- **************************************************************************'
' FUNCTION DecToHex(DEC AS STRING) AS STRING
' DEFDBL ost , ch
' DEFSTR HexVal$
' HexVal$ = ""
' ost = 0: ch = 0
' Dec# = VAL(DEC)
' sign = SGN(Dec#)
' Dec# = ABS(Dec#)
' WHILE Dec# >= 16#
' ch = FIX(Dec# / 16#)
' ost = Dec# - ch * 16#
'
' Dec# = ch
' SELECT CASE ost
' CASE IS < 10
' Hexdig$ = STR$(ost)
' CASE 10
' Hexdig$ = "A"
' CASE 11
' Hexdig$ = "B"
' CASE 12
' Hexdig$ = "C"
' CASE 13
' Hexdig$ = "D"
' CASE 14
' Hexdig$ = "E"
' CASE 15
' Hexdig$ = "F"
' CASE 15
' Hexdig$ = "10"
'
' CASE ELSE
' END SELECT
'
' HexVal$ = Hexdig$ + HexVal$:
'
' WEND
'
' SELECT CASE Dec#
'
' CASE IS < 10
' Hexdig$ = STR$(Dec#)
' CASE 10
' Hexdig$ = "A"
' CASE 11
' Hexdig$ = "B"
' CASE 12
' Hexdig$ = "C"
' CASE 13
' Hexdig$ = "D"
' CASE 14
' Hexdig$ = "E"
' CASE 15
' Hexdig$ = "F"
' CASE 15
' Hexdig$ = "10"
'
' CASE ELSE
' END SELECT
'
' HexVal$ = Hexdig$ + HexVal$:
' IF sign = - 1 THEN signn$ = "-" ELSE signn$ = ""
' IF HexVal$ = "0" THEN HexVal$ = "00"
' dectoHex = signn$ + HexVal$
' END FUNCTION
'-- **************************************************************************'
FUNCTION AddChrBefore(NumStr AS STRING , Dlina AS INTEGER , chr AS STRING) AS STRING
'Andrew Shelkovenko dec 2003
'A function that pre-padd string with chr to required Length
'print AddChrBefore("-387.35" , 10, "=")
'==-0387.35
DIM kolvo AS INTEGER
kolvo = Dlina - LEN(NumStr)
IF kolvo < 0 THEN AddChrBefore = "String too long"
IF kolvo = 0 THEN AddChrBefore = NumStr: EXIT FUNCTION
AddChrBefore = STRING$(kolvo , chr) + NumStr
END FUNCTION
'-- **************************************************************************'
FUNCTION Add0Before(NumStr AS STRING , Dlina AS INTEGER) AS STRING
'Andrew Shelkovenko dec 2003
'A function that pre-padd string with 0's to required Length
'print Add0Before("-387.35" , 8)
'-0387.35
DIM kolvo AS INTEGER
kolvo = Dlina - LEN(NumStr)
IF kolvo < 0 THEN Add0Before = "String too long"
IF kolvo = 0 THEN Add0Before = NumStr: EXIT FUNCTION
Add0Before = STRING$(kolvo , "0") + NumStr
END FUNCTION
'-- **************************************************************************'
FUNCTION ByteReOrder(ByteStr$ , ReOrder$) AS STRING
'Andrew Shelkovenko dec 2003
'A function that reorder bytes in string.
'ByteStr$ - Sourse string
'ReOrder$ - new byte order
'ReOrder$="21342"
'old position - 2, new position - 1
'old position - 1, new position - 2
'old position - 3, new position - 3
'old position - 4, new position - 4
'old position - 2, new position - 5
DEFINT LenB = LEN(ByteStr$), LenR = LEN(ReOrder$), i
DEFSTR poz$, byt$, tmp$
FOR i = 1 TO LenB
poz$ = ReOrder$[i]
IF VAL(poz$) > LenB THEN SHOWMESSAGE("ReOrder index outbound input string") :exit FUNCTION
IF i <= LenR THEN
byt$ = ByteStr$[val(poz$) ]
ELSE
byt$ = ByteStr$[i]
END IF
tmp$ = tmp$ + byt$
NEXT
ByteReOrder = tmp$
END FUNCTION
'-- **************************************************************************'
FUNCTION CByteNum(ByteStr$ , Num_Type AS SHORT) AS VARIANT
'Andrew Shelkovenko dec 2003
'converts number of Num_Type type to bytes sequence.
'Num_Type can be next value:
'const Num_SHORT = 2
'const Num_WORD = 3
'const Num_LONG = 4
'const Num_DWORD = 5
'const Num_SINGLE = 6
'const Num_DOUBLE = 8
DIM M AS QMEMORYSTREAM
SELECT CASE Num_Type
CASE Num_BYTE
SHOWMESSAGE "Can't to write BYTE.Wrong parameter type - Num_BYTE": EXIT FUNCTION
CASE Num_SHORT: M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_SHORT)
CASE Num_WORD: M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_WORD)
CASE Num_LONG: M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_LONG)
CASE Num_DWORD: M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_DWORD)
CASE Num_SINGLE:M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_SINGLE)
CASE Num_DOUBLE:M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_DOUBLE)
CASE ELSE
M.Write(ByteStr$) :m.Position = 0:CByteNum = M.ReadNum(Num_DOUBLE)
END SELECT
M.Close
END FUNCTION
'-- **************************************************************************'
FUNCTION CNumByte(Num , Num_Type AS SHORT) AS STRING
'Andrew Shelkovenko dec 2003
'converts bytes sequence to number of Num_Type type
'Num_Type can be next value:
'const Num_SHORT = 2
'const Num_WORD = 3
'const Num_LONG = 4
'const Num_DWORD = 5
'const Num_SINGLE = 6
'const Num_DOUBLE = 8
DIM M AS QMEMORYSTREAM
SELECT CASE Num_Type
CASE Num_BYTE
DIM N1 AS BYTE
SHOWMESSAGE "Can't to write BYTE.Wrong parameter type - Num_BYTE": EXIT FUNCTION
CASE Num_SHORT: DEFSHORT N2:N2 = Num:M.Write(N2) :M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N2))
CASE Num_WORD: DEFWORD N3:N3 = Num:M.Write(N3) :M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N3))
CASE Num_LONG: DEFLNG N4:N4 = Num:M.Write(N4) :M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N4))
CASE Num_DWORD: DEFDWORD N5:N5 = Num:M.Write(N5) :M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N5))
CASE Num_SINGLE:DEFSNG N6:N6 = Num:M.Write(N6) :M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N6))
CASE Num_DOUBLE:DEFDBL N7:N7 = Num:M.Write(N7) :M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N7))
CASE ELSE
DIM N8 AS DOUBLE:N8 = Num:
M.Write(N8) :
M.Position = 0:CNumByte = M.ReadBinStr(SIZEOF(N8)) :M.Close
END SELECT
M.Close
END FUNCTION
'-- **************************************************************************'
'LIKE Function - pattern matching routine for Rapid-Q by William Yu
'This emulates the VB LIKE operator.
'Thanks to Thomas Binder for the original C code
'
'? Any single character.
'* Zero or more characters.
'# Any single digit (0-9).
'[charlist] Any single character in charlist.
'[!charlist] Any single character not in charlist.
'
'A group of one or more characters (charlist) enclosed in brackets ([ ])
'can be used to match any single character in string and can include almost
'any character code, including digits.
'
'Note: To match the special characters left bracket ([), question
'mark (?), number sign (#), and asterisk (*), enclose them in brackets.
'The right bracket (]) can't be used within a group to match itself, but
'it can be used outside a group as an individual character.
'
'By using a hyphen (-) to separate the upper and lower bounds of the range,
'charlist can specify a range of characters. For example, [A-Z] results in
'a match if the corresponding character position in string contains any
'uppercase letters in the range A-Z. Multiple ranges are included within
'the brackets without delimiters.
'CONST INVERT = "!" '-- Some like ^ or ~ instead, whatever you want
'-- **************************************************************************'
FUNCTION IsDigit(S AS STRING) AS INTEGER
IF S >= "0" AND S <= "9" THEN
IsDigit = 1
ELSE
IsDigit = 0
END IF
END FUNCTION
'-- **************************************************************************'
' FUNCTION Like(ParseString AS STRING , Pattern AS STRING) AS INTEGER
' DIM prev AS INTEGER , matched AS INTEGER , reverse AS INTEGER
'
' WHILE Pattern <> ""
' SELECT CASE MID$(Pattern , 1 , 1)
' CASE "?"
' IF ParseString = "" THEN
' Like = 0
' EXIT FUNCTION
' END IF
' CASE "#"
' IF IsDigit(MID$(ParseString , 1 , 1)) = 0 THEN
' Like = 0
' EXIT FUNCTION
' END IF
' CASE "*"
' DO
' Pattern = MID$(Pattern , 2 , LEN(Pattern) - 1)
' LOOP UNTIL MID$(Pattern , 1 , 1) <> "*"
' IF Pattern = "" THEN
' Like = 1
' EXIT FUNCTION
' END IF
' WHILE ParseString <> ""
' IF Like(ParseString , Pattern) THEN
' Like = 1
' EXIT FUNCTION
' END IF
' IF ParseString <> "" THEN
' ParseString = MID$(ParseString , 2 , LEN(ParseString) - 1)
' END IF
' WEND
' Like = 0
' EXIT FUNCTION
' CASE "["
' reverse =(MID$(Pattern , 2 , 1) = "!") 'INVERT)
' IF reverse THEN
' Pattern = MID$(Pattern , 2 , LEN(Pattern) - 1)
' END IF
' prev = 256: matched = 0
' DO
' Pattern = MID$(Pattern , 2 , LEN(Pattern) - 1)
' IF (Pattern <> "") AND (esc <> 0 OR MID$(Pattern , 1 , 1) <> "]") THEN
' IF MID$(Pattern , 1 , 1) = "-" THEN
' Pattern = MID$(Pattern , 2 , LEN(Pattern) - 1)
' IF Pattern = "" THEN
' Like = 0
' EXIT FUNCTION
' END IF
' matched = matched OR (MID$(ParseString , 1 , 1) <= MID$(Pattern , 1 , 1) AND ASC(MID$(ParseString , 1 , 1)) >= prev)
' ELSE
' matched = matched OR (MID$(ParseString , 1 , 1) = MID$(Pattern , 1 , 1))
' END IF
' prev = ASC(MID$(Pattern , 1 , 1))
' ELSE
' EXIT DO
' END IF
' esc = 0
' LOOP
' IF (prev = 256 OR MID$(Pattern , 1 , 1) <> "]" OR ABS(matched) = ABS(reverse)) THEN
' Like = 0
' EXIT FUNCTION
' END IF
' CASE ELSE
' IF MID$(ParseString , 1 , 1) <> MID$(Pattern , 1 , 1) THEN
' Like = 0
' EXIT FUNCTION
' END IF
' END SELECT
' ParseString = MID$(ParseString , 2 , LEN(ParseString) - 1)
' Pattern = MID$(Pattern , 2 , LEN(Pattern) - 1)
' WEND
'
' Like = ABS(LEN(ParseString) = 0)
' END FUNCTION
'-- Test code
'print "Like('24','##')=", Like("24","##")
'?"Like(aBBBa, a*a)=", Like("aBBBa","a*a")
'?Like("F","[!A-Z]")
'?Like("a2a","a#a")
'?Like("aM5b","a[A-GL-P]#[!c-e]")
'?Like("BAT123khg","B?T*")
'?Like("CAT123khg","B?T*")
'?Like("Combine(10, 20) = 30", "*(*?,*?)*=*#")
'-- **************************************************************************'
FUNCTION SecTime(cTime$ AS STRING) AS INTEGER
DEFINT TimeHH = VAL(FIELD$(cTime$ , ":" , 1))
DEFINT TimeMM = VAL(FIELD$(cTime$ , ":" , 2))
DEFINT TimeSS = VAL(FIELD$(cTime$ , ":" , 3))
Result = TimeHH * 3600 + TimeMM * 60 + TimeSS
END FUNCTION
'-- **************************************************************************'
FUNCTION DayDate(cDate$ AS STRING) AS INTEGER
DEFINT MM = VAL(FIELD$(cDate$ , "-" , 1))
DEFINT Day = VAL(FIELD$(cDate$ , "-" , 2))
DEFINT Year = VAL(FIELD$(cDate$ , "-" , 3))
Result = 365 *(Year) + 30 *(MM) +(Day)
END FUNCTION
'-- **************************************************************************'
' FUNCTION TimeString(TimSec AS INTEGER) AS STRING
'
' Hr% = TimSec / 3600
' SecMin = TimSec - Hr% * 3600
' Min% =(SecMin) / 60
' Sec% = SecMin - Min% * 60
'
' Hr$ = RIGHT$("0" + STR$(Hr%) , 2)
' Min$ = RIGHT$("0" + STR$(Min%) , 2)
' Sec$ = RIGHT$("0" + STR$(Sec%) , 2)
'
' TimeString = Hr$ + ":" + Min$ + ":" + Sec$ + " "
'
' END FUNCTION
'-- *********************************************************************'
FUNCTION GetWord(Oper$ AS STRING , getV$ AS STRING) AS LONG
'return variable position in checked string
'getV$ - variable name
'Oper$ - checked string
'if getV$ commented, or quoted (just text, not varname) - return error code
Result = - 1 'error
DEFSTR Lsep$ = "([=><, :+-*\/;"
DEFSTR Rsep$ = ")]=><, :'+-*\/;"
DEFSTR qt = CHR$(34)
DEFINT Wpos, QPos1, QPos2, CPos
Oper$ = LCASE$(Oper$)
getV$ = LCASE$(getV$)
Wpos = INSTR(Oper$ , getV$)
'print "Wpos=" ,Wpos
IF Wpos = 0 THEN Result = 0: EXIT FUNCTION 'pattern not contained
'check comment and string
WHILE Wpos > 0
'print "Wpos=" ,Wpos
'print "Wpos+len(getV$)=" ,Wpos+len(getV$)
'print "len(Oper$)=" ,len(Oper$)
IF (INSTR(Lsep$ , Oper$[Wpos - 1]) > 0 OR Wpos = 1) AND (INSTR(Rsep$ , Oper$[Wpos + LEN(getV$) ]) > 0 OR Wpos + LEN(getV$) - 1 = LEN(Oper$)) THEN
'check string
QPos1 = rinstr(Wpos , Oper$ , qt) '1 quote pos
'print "QPos1=" ,QPos1
QPos2 = INSTR(Wpos , Oper$ , qt) '2 quote pos
'print "QPos2=" ,QPos2
CPos = rinstr(Wpos , Oper$ , "'") 'comment pos
'print "CPos=" ,CPos
IF QPos1 < Wpos AND QPos2 > Wpos AND QPos1 > 0 THEN 'it's string, not var
ELSEIF (CPos < Wpos AND CPos > 0) AND QPos1 < CPos THEN 'it's comment and QPos2>0
ELSE
Result = Wpos
'print "Wpos1=" ,Wpos
EXIT WHILE
END IF
ELSE
END IF
Wpos = INSTR(Wpos + 1 , Oper$ , getV$)
'print "Wpos2=" ,Wpos
Result = - 2 'present, but not var
WEND
END FUNCTION