'--------------------------- 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", "*(*?,*?)*=*#")