' BB Function Helper Library
' BB_ATH - Business BASIC ATH() function
'
' Converts a text string of hex character pairs to ASCII values.
'
FUNCTION BB_ATH(HexStr)
LOCAL LenHex, AsciiStr, HexTable, ScanPos, HiByte, LowByte
LenHex = LEN(HexStr)
IF LenHex % 2 = 0 THEN
HexTable = "0123456789ABCDEF"
FOR ScanPos = 1 TO LenHex STEP 2
HiByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos, 1))) - 1
LowByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos + 1, 1))) - 1
IF ISINTEGER(HiByte) AND ISINTEGER(LowByte) THEN
AsciiStr &= CHR(HiByte * 16 + LowByte)
ELSE
AsciiStr = ""
GOTO Exit_For
END IF
NEXT ScanPos
Exit_For:
ELSE
AsciiStr = ""
END IF
BB_ATH = AsciiStr
END FUNCTION
' BB_CVS - Business Basic CVS() function
'
' Action:
' 1 = Remove Leading characters
' 2 = Remove Trailing characters
' 4 = Convert String to Upper Case
' 8 = Convert String to Lower Case
' 16 = Replace characters < 32 with the control character
' 32 = Replace multiple occurrence of the character with one
' 64 = * Replace $ with defined Windows currency symbol
' 128 = * Replace defined Windows currency, comma and thousand symbol
' 256 = * Ucase first char of each word, rest to lower
' * = Not implemented yet.
'
FUNCTION BB_CVS(StrExpr, Action, CtrlChar)
LOCAL Char, ExprLen, TempStr, ScanPos
IF CtrlChar = undef THEN CtrlChar = " "
Char = ASC(CtrlChar)
' Remove Leading characters
IF (Action AND 1) THEN
ExprLen = LEN(StrExpr)
IF CtrlChar = " " THEN
StrExpr = LTRIM(StrExpr)
ELSE
TempStr = ""
FOR ScanPos = 1 TO ExprLen
IF MID(StrExpr, ScanPos, 1) <> CtrlChar THEN TempStr &= MID(StrExpr, ScanPos, 1)
NEXT ScanPos
StrExpr = TempStr
END IF
END IF
' Remove Trailing characters
IF (Action AND 2) THEN
ExprLen = LEN(StrExpr)
IF CtrlChar = " " THEN
StrExpr = RTRIM(StrExpr)
ELSE
TempStr = ""
FOR ScanPos = ExprLen TO 1 STEP - 1
IF MID(StrExpr, ScanPos, 1) = CtrlChar THEN TempStr = LEFT(StrExpr, ScanPos - 1)
NEXT ScanPos
IF LEN(TempStr) THEN StrExpr = TempStr
END IF
END IF
' Convert String to Upper Case
IF (Action AND 4) THEN
StrExpr = UCASE(StrExpr)
END IF
' Convert String to Lower Case
IF (Action AND 8) THEN
StrExpr = LCASE(StrExpr)
END IF
' Replace characters < 32 with the control character
IF (Action AND 16) THEN
FOR ScanPos = 1 TO LEN(StrExpr)
IF ASC(MID(StrExpr, ScanPos, 1)) < 32 THEN StrExpr = LEFT(StrExpr, ScanPos -1) & CtrlChar & MID(StrExpr, ScanPos + 1)
NEXT ScanPos
END IF
' Replace multiple occurence of the character with one
IF (Action AND 32) THEN
HitCnt = 0
StartPos = 1
NextPos:
ScanPos = INSTR(StrExpr,CtrlChar,StartPos)
IF ISINTEGER(ScanPos) THEN
IF HitCnt THEN
IF ASC(MID(StrExpr, ScanPos,1)) = CtrlChar THEN TeStrExpr = LEFT(StrExpr, ScanPos -1) & MID(StrExpr, ScanPos + 1)
ELSE
HitCnt += 1
END IF
StartPos += 1
GOTO NextPos
END IF
END IF
BB_CVS = StrExpr
END FUNCTION
' BB_DEC - Business BASIC DEC() function
'
' Returns a two's complement binary equivalent of the string.
'
FUNCTION BB_DEC(BinStr)
LOCAL i, d
FOR i = LEN(BinStr) TO 1 STEP -1
d += ASC(MID(BinStr,i,1)) * 256 ^ ABS(i - LEN(BinStr))
NEXT i
BB_DEC = d
END FUNCTION
' BB_HTA - Business BASIC HTA() function
'
' Returns the hexadecimal text string of the pasted argument string.
'
FUNCTION BB_HTA(AsciiStr)
LOCAL AsciiLen,ScanPos,HexStr
AsciiLen = LEN(AsciiStr)
IF AsciiLen THEN
FOR ScanPos = 1 TO AsciiLen
HexStr &= RIGHT("0" & HEX(ASC(MID(AsciiStr, ScanPos, 1))),2)
NEXT ScanPos
ELSE
HexStr = ""
END IF
BB_HTA = HexStr
END FUNCTION
' BB_JUL - Business BASIC JUL() function
'
' Converts a date from year, month, day to a Julian date.
'
FUNCTION BB_JUL(Y,M,D)
IF Y = undef AND M = undef AND D = undef THEN
BB_JUL = NOW
ELSE
BB_JUL = TIMEVALUE(Y,M,D)
END IF
END FUNCTION
' BB_LRC - Business Basic LRC() function.
'
' Returns a one byte string containing the longitudinal redundancy checksum of a character string.
'
FUNCTION BB_LRC(ArgStr)
LOCAL ArgStrLen, ScanPos, LRCVal
LRCVal = 0
ArgStrLen = LEN(ArgStr)
IF ArgStrLen THEN
FOR ScanPos = 1 TO ArgStrLen
LRCVal += LRCVal XOR ASC(MID(ArgStr, ScanPos, 1))
NEXT ScanPos
BB_LRC = CHR(LRCVal)
ELSE
BB_LRC = CHR(&H00)
END IF
END FUNCTION
' BB_PAD - Business BASIC PAD() funtion
'
' Returns a character string of the length specified (NumExpr)
'
' NOTE: StrExpr = String to be processed
' NewLen = Desired length of string
' HowToPad = This parameter defines how to pad the string
' 0 - Pad on left (right justify)
' 1 - Pad on right (left justify)
' 2 - Center in string
' StrPad = First character of this string used to pad StrExpr
'
FUNCTION BB_PAD(StrExpr,NewLen,HowToPad,StrPad)
LOCAL StrExpr,NewLen,HowToPad,StrPad,PadVal,StrExprLen,ResultStr,RLPLen
IF HowToPad = undef THEN
PadVal = 1
ELSE IF HowToPad = 0 OR UCASE(HowToPad) = "L" THEN
PadVal = 0
ELSE IF HowToPad = 1 OR UCASE(HowToPad) = "R" THEN
PadVal = 1
ELSE IF HowToPad = 2 OR UCASE(HowToPad) = "C" THEN
PadVal = 2
ELSE
BB_ERR = 41
BB_PAD = ""
EXIT FUNCTION
END IF
IF StrPad = undef THEN StrPad = " "
StrExprLen = LEN(StrExpr)
IF PadVal = 0 THEN
IF NewLen < StrExprLen THEN
ResultStr = RIGHT(StrExpr, NewLen)
ELSE
ResultStr = STRING(NewLen - StrExprLen, StrPad) & StrExpr
END IF
END IF
IF PadVal = 1 THEN
IF NewLen < StrExprLen THEN
ResultStr = LEFT(StrExpr, NewLen)
ELSE
ResultStr = StrExpr & STRING(NewLen - StrExprLen, StrPad)
END IF
END IF
IF PadVal = 2 THEN
IF NewLen < StrExprLen THEN
ResultStr = LEFT(StrExpr, NewLen)
ELSE
RLPLen = (NewLen - StrExprLen) / 2
IF RLPLen % 2 THEN
ResultStr = STRING(FIX(RLPLen),StrPad) & StrExpr & STRING(FIX(RLPLen) + 1,StrPad)
ELSE
ResultStr = STRING(RLPLen,StrPad) & StrExpr & STRING(RLPLen,StrPad)
END IF
ENDIF
END IF
BB_PAD = ResultStr
END FUNCTION
' BB_POS - Business Basic POS() function
'
' BB_POS follows these logic steps:
'
' 1. If stringA or StringB is null, return 0
' 2. Start with first byte in stringB if intA is positive, or the Nth byte
' from the end of stringB if intA is negatine (-N).
' 3. If past either the begining or end of stringB then return 0
' (or occurrence count if intB is 0)
' 4. Compare stringA with the substring at the current position in stringB.
' The length of substring will be either the length of stringA or the
' remainder of stringB, whichever is shorter.
' 5. If a given releationship is true and if this was the Nth successful
' try (specified by intB=N) then return the current scan position.
' 6. If the relation was not satisfied then bump the scan position
' (possibly backwards if intA is negative) and go to step 3 and try again.
'
' Relationship Operators:
'
' "=" - Equal To
' "<" - Less Than
' ">" - Greater Than
' "<=" - Less Than Or Equal To
' ">=" - Greater Than Or Equal To
' "<>" - Not Equal To
' ":" - Equal to Any
' "^" - Not Equal To Any
'
FUNCTION BB_POS(MatchStr,ScanStr,Relate,IncVal,OccurVal)
LOCAL LenMatchStr,LenScanStr,ScanPos,OccurCnt,Item,StartVal,EndVal
IF Relate = undef THEN Relate = "="
IF IncVal = undef THEN IncVal = 1
IF OccurVal = undef THEN OccurVal = 1
LenMatchStr = LEN(MatchStr)
IF INSTR(":^", Relate) THEN LenMatchStr = 1
LenScanStr = LEN(ScanStr)
IF LenMatchStr = 0 OR LenScanStr = 0 OR OccurVal < 0 THEN
BB_POS = 0
EXIT FUNCTION
END IF
IF IncVal > 0 THEN
StartVal = 1
EndVal = LenScanStr
ELSE
StartVal = LenScanStr
EndVal = 1
END IF
FOR ScanPos = StartVal TO EndVal STEP IncVal
Item = MID(ScanStr, ScanPos, LenMatchStr)
IF Relate = "=" THEN
IF MatchStr = Item THEN OccurCnt += 1
ELSE IF Relate = "<" THEN
IF MatchStr < Item THEN OccurCnt += 1
ELSE IF Relate = ">" THEN
IF MatchStr > Item THEN OccurCnt += 1
ELSE IF Relate = "<=" OR Relate = "=<" THEN
IF MatchStr <= Item THEN OccurCnt += 1
ELSE IF Relate = ">=" OR Relate = "=>" THEN
IF MatchStr >= Item THEN OccurCnt += 1
ELSE IF Relate = "<>" OR Relate = "><" THEN
IF MatchStr <> Item THEN OccurCnt += 1
ELSE IF Relate = ":" THEN
IF INSTR(MatchStr, Item) THEN OccurCnt += 1
ELSE IF Relate = "^" THEN
IF NOT ISNUMERIC(INSTR(MatchStr, Item)) THEN OccurCnt += 1
ELSE
BB_POS = 0
EXIT FUNCTION
END IF
IF OccurVal > 0 THEN
IF OccurCnt = OccurVal THEN GOTO Done
END IF
NEXT ScanPos
Done:
IF OccurVal = 0 THEN
BB_POS = OccurCnt
ELSE IF OccurCnt THEN
BB_POS = ScanPos
ELSE
BB_POS = 0
END IF
END FUNCTION
Recent Posts