Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA"_
(ByVal lpFileName As String) As Long
Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA"_
(ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" _
(ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
'# QUOTE : Returns a quoted string
function Quote (StringToQuote as string) as string
StringToQuote = chr$(34) + StringToQuote + chr$(34)
result = replacesubstr$(stringtoquote, chr$(34) + chr$(34), chr$(34))
end function
'===============================================================================
'# STRIPPATH : Returns file path (without file name)
Function StripPath (fullname as string) as string
result = left$(fullname, rinstr(fullname, "\"))
end function
'===============================================================================
'# STRIPFILENAME : Returns file name (without path)
Function StripFileName (fullname as string) as string
result = right$(fullname, len(fullname) - rinstr(fullname, "\"))
end function
'===============================================================================
'# STRIPFILEEXT : Returns file extension (like ".exe", ".html" etc.)
Function StripFileExt (fullname as string) as string
result = right$(fullname, len(fullname) - rinstr(fullname, ".") + 1)
end function
'===============================================================================
'# FILENAMENOEXT : Returns file name without extension
function FileNameNoExt(fullname as string) as string
fullname = right$(fullname, len(fullname) - rinstr(fullname, "\"))
result = left$(fullname, rinstr(fullname, ".") - 1)
end function
'===============================================================================
'# FULLPATHNOEXT : Returns full path without file extension
function FullPathNoExt(fullname as string) as string
result = left$(fullname, rinstr(fullname, ".") - 1)
end function
'===============================================================================
'# C_Style : Returns "slashed" path from a "backslashed" one
function C_Style (fullname as string) as string
fullname = replacesubstr$(fullname, "\\", "\")
result = replacesubstr$(fullname, "\", "/")
end function
'===============================================================================
'# SYSDIR : Retrieves windows shell directories
'-------------------------|
' Allowed values for dir |
'-----------------------------------------------------------------------------|
' Desktop | Templates | AppData |
' Start Menu | Programs | Startup |
' Fonts | SendTo | Recent |
' Favorites | Cache | Cookies |
' History | NetHood | Personal |
' PrintHood | Local AppData | My Pictures |
' Administrative Tools | | |
'-----------------------------------------------------------------------------|
function SysDir (dir as string) as string
DIM fo_reg AS QRegistry
fo_reg.RootKey = &H80000001
fo_reg.openkey ("Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", 0)
result = fo_reg.readstring(dir) + "\"
end function
'===============================================================================
'# HOMEDIR : The folder where the application is
function homedir() as string
result = left$(command$(0), rinstr(command$(0), "\"))
end function
'===============================================================================
'# BROWSEFORFOLDERS : Returns the selected folder
function BrowseForFolders (initialdir as string, wincapt as string) as string
dim bff_form as qform
with bff_form
.height = 400
.center
.caption = wincapt
.delbordericons 2
end with
dim bff_tree as qdirtree
with bff_tree
.parent = bff_form
.align = 5
end with
if bff_form.caption = "" then bff_form.caption = "Select folder"
if direxists(initialdir) then
bff_tree.directory = initialdir
else
bff_tree.directory = curdir$
end if
bff_form.showmodal
result = bff_tree.directory
end function
'===============================================================================
'# BROWSEFORFILE : Returns the selected folder
Function BrowseForFile (caption as string, filter as string, _
initialdir as string) as string
dim bff_od as qopendialog
with bff_od
.caption = caption
.filter = filter
.initialdir = initialdir
if .execute then
result = .filename
end if
end with
end function
'_=============================================================================
$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
if FileName="" then showmessage ("FUNCTION SaveString. Wrong FileName="+FileName)
DIM fileStr as QFileStream
result=0
fileStr.open (FileName,65535 ) 'fmCreate'
result=-1
FileStr.WriteStr(ss$, len(ss$))
FileStr.Close
result=1
END FUNCTION
'-- *****************************************************'
FUNCTION LoadString(FileName as STRING ) AS string
DIM fileStr as QFileStream
result="0"
'fmOpenRead = 0
if fileStr.open (FileName,0 ) then'fmCreate'
result="-1"
result=FileStr.ReadStr( FileStr.size)
FileStr.Close
'result=1
end if
END FUNCTION
'_==============================================================
'-- *****************************************************'
sub MKSubDir (DirDst$)
'Andrew Shelkovenko dec 2003
'Create DirDst$ directory with full subdir structure
z1=instr(DirDst$,"\")
z2=0
while z1>0
SubDirDst$=left$(DirDst$,z1 )
if DIREXISTS(SubDirDst$)=0 then MKDIR SubDirDst$
'print "SubDirDst$=" ,SubDirDst$
z2=z1+1
z1=instr(z2,DirDst$,"\")
wend
end sub
'-- *****************************************************'
sub SubDirCopy (DirSrc$, DirDst$, mask$) '- -----------------------------------'
'Andrew Shelkovenko dec 2003
'Copy DirSrc$ directory with full subdir structure and files (by mask$) to DirDst$
dim FileSrc as QFileStream
dim FileDst as QFileStream
'Index=0
NumFiles=0
defint nsd1, nsd2
defstr mask
nsd1=0:nsd2=0
NumDir=0
ArrNumDir=500
dim SubDir(500) as string
ArrNumFil=500
dim FileNames (500) as string
mask="*.*"
SubDir(0)=DirSrc$
1
for i=NSD1 to Nsd2 'current level sudirs'
'print "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 "SubDir(", NumDir, ")=",SubDir(NumDir)
else
end if
SubDirname$=dir$
doevents:if stops1=1 then stops1=0: exit sub
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 1 '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
for i1=0 to i-1
NewSubDir$=SubDir(i1)-DirSrc$
NewSubDir$=DirDst$+NewSubDir$
MKSubDir (NewSubDir$)
next i1
for j=1 to NumFiles
FileSrc.Open(FileNames(j), fmOpenRead)
NewFileName$=FileNames(j)-DirSrc$
NewFileName$=DirDst$+NewFileName$
'print "NewFileName$=" ,NewFileName$
FileDst.Open(NewFileName$, fmCreate)
FileDst.CopyFrom (FileSrc, 0)''
FileSrc.close''
FileDst.close
next j
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
NumFiles=0
defint nsd1, nsd2
defstr mask
nsd1=0:nsd2=0
NumDir=0
ArrNumDir=500
dim SubDir(500) as string
ArrNumFil=500
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:if stops1=1 then stops1=0: exit sub
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
for i1=i-1 to 1 step -1
RMDIR SubDir(i1)
'print "-- KillSubDir RMDIR SubDir(",i1,")=", SubDir(i1)
next i1
END SUB
sub DirCopy (DirSrc$, DirDst$, mask$) '- -----------------------------------'
'Andrew Shelkovenko dec 2003
'Copy files (by mask$) from DirSrc$ to DirDst$
dim FileSrc as QFileStream
dim FileDst as QFileStream
MKDIR DirDst$
FileName$ = DIR$(DirSrc$+mask$, 0) '-- Get first file
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 rest
wend
'print "copied= "+str$(rest) +" files
rest=0
end sub
'-- ***********************************************************************'
sub FileCopy (FileSrc$, FileDst$) '- -----------------------------------'
'Andrew Shelkovenko dec 2003
'Copy FileSrc$ to FileDst$
' if path dest is not exist - create it.
dim FileSrc as QFileStream
dim FileDst as QFileStream
dr$=StripPath (FileDst$)
MKDIR dr$ 'StripPath (FileDst$)
if DIREXISTS(dr$ ) =0 then showmessage ("Can't create directory "+dr$ ): exit sub
FileSrc.Open(FileSrc$, fmOpenRead)
FileDst.Open(FileDst$, fmCreate)
FileDst.CopyFrom (FileSrc, 0)
FileSrc.close
FileDst.close
end sub
'-- ***********************************************************************'
sub KillFiles (FileName$)
'Andrew Shelkovenko diakin@narod.ru apr 2004
'Kill files in FileName$
' for example KillFiles "C:\BAS\RAPIDQ\tmp\*.tmp"
FName$ = DIR$(FileName$, 0) '-- Get first file
while FName$ <>""
kill FName$
'if fileexists (FName$)>0 then print "Can't kill file "+FName$
FName$ = DIR$ '-- Get next file
wend
end sub
'-- ***********************************************************************'
SUB io2Rnd (fsrc$, fdst$)
'--------------------------------
'convert text file with single value strings to binary
' for example
'17.78091
'16.64166
'19.87037
'21.29429
'15.64965
'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
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
' for example
'17.78091
'16.64166
'19.87037
'21.29429
'15.64965
'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
FileSourse.Open (fsrc$, 2 ) 'fmOpenReadWrite'
FileDest.Open (fdst$, 65535 ) 'fmOpenCreate'
ie = FileSourse.size/4: 'print "ie=" ,ie
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