' COMPRES$(0.0) Compress Character String 12/22/1988-02/01/2010 ' ------------------------------------------------------------------------------ ' Copyright (C) 1988-2010 by Vladimir Veytsel www.davar.net ' Type ------------------------------------------------------------------------- ' Function ' Description ------------------------------------------------------------------ ' COMPRES$ function returns its first parameter with all successive ' occurrences of characters specified by the second parameter being ' compressed to a single occurrence. ' Parameters ------------------------------------------------------------------- ' Strng$ - Character string to be compressed. ' Chars$ - Characters, all successive occurrences of which ' should to be compressed to a single occurrence. ' Value ------------------------------------------------------------------------ ' Character string compressed as specified by Chars$ parameter. ' Note ------------------------------------------------------------------------- ' Empty Chars$ parameter specifies compression of ALL successive ' duplicate characters of the string. ' Examples --------------------------------------------------------------------- ' COMPRES$("" ,"" )="" ' COMPRES$("ABBCCC","" )="ABC" ' COMPRES$("ABBCCC","A" )="ABBCCC" ' COMPRES$("ABBCCC","B" )="ABCCC" ' COMPRES$("ABBCCC","C" )="ABBC" ' COMPRES$("ABBCCC","ABC")="ABC" ' Start Function --------------------------------------------------------------- DEFINT A-Z ' All defaulted variables are integer FUNCTION COMPRES$(Strng$,Chars$) ' Check Special Case (Compression Is Impossible) ------------------------------- IF (LEN(Strng$)<2) THEN COMPRES$=Strng$ EXIT FUNCTION END IF ' Form Compressed String (with the Exception of Last Symbol) ------------------- Chars_Lngth=LEN(Chars$) FOR I=1 TO LEN(Strng$)-1 Curr_Str_Symb$=MID$(Strng$,I ,1) Next_Str_Symb$=MID$(Strng$,I+1,1) IF (( Curr_Str_Symb$<>Next_Str_Symb$)OR _ ((Curr_Str_Symb$= Next_Str_Symb$)AND _ (Chars_Lngth>0) AND _ (INSTR(Chars$,Curr_Str_Symb$)=0))) THEN Work_Str$=Work_Str$+Curr_Str_Symb$ END IF NEXT I ' Return Function Value to the Point of Invocation ----------------------------- COMPRES$=Work_Str$+RIGHT$(Strng$,1) ' Finish Function -------------------------------------------------------------- END FUNCTION