'--------------------------- Custom functions --------------------------
'-- **************************************************************************'
FUNCTION vidnum$ (Num, dig%) as string
'Andrew Shelkovenko dec 2003
'A function that returns the string representation of of a rounded numeric expression.
'Syntax: vidnum$ (numeric-expression, dig%)
'Num$ = vidnum$ (999999.2366666666, 4)
'Return 999999.2367
'Num$ = vidnum$ (-0.236, 4)
'Return -0.236
'Num$ =vidnum$ (-12389.236, -2)
'Return -12400
'Details:
'dig% - number of significant digits
Num$=str$(Num)
pntPos=instr(Num$,".")
if pntPos=0 then
digMax=0
else
digMax=Len(Num$)-pntPos
end if
if dig%>digMax then dig%=digMax
vidnum$ = STR$(( CLNG( abs(Num) * 10 ^ dig%) / 10 ^ dig%)*sgn(Num))
END FUNCTION
'
'-- **************************************************************************'
function Hex2Dec (HexStr as string) as string
DEFdbl numb
defdbl number
DEFBYTE x,length, y
number = 0
length = LEN(HexStr)
FOR x = 1 TO length
y = length - x
digit$ = UCASE$(MID$(HexStr,x,1))
SELECT CASE digit$
CASE "A"
numb = 10 * 16^y
CASE "B"
numb = 11 * 16^y
CASE "C"
numb = 12 * 16^y
CASE "D"
numb = 13 * 16^y
CASE "E"
numb = 14 * 16^y
CASE "F"
numb = 15 * 16^y
CASE ELSE
numb = VAL(LCASE$(digit$)) * 16^y
END SELECT
number = number + numb
qw:
NEXT
if number>10^6 then
n1=fix(number/1000000)
n2=(number-n1*1000000)
NumNul=6-len(str$(n2))
TrNul$=string$(NumNul, "0")
Dec$ = STR$(n1)+TrNul$+str$(n2)
else
Dec$ = STR$(number)
end if
Hex2Dec=Dec$
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 AddStrBefore(NumStr as string , Dlina as int, AddStr as string) 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 int
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
LenB=Len(ByteStr$)
LenR=Len(ReOrder$)
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.
DECLARE FUNCTION Like(ParseString AS STRING, Pattern AS STRING) AS INTEGER
DECLARE FUNCTION IsDigit(S AS STRING) AS INTEGER
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", "*(*?,*?)*=*#")