Code:
'------------------------------------------------------------------------------ ' Unit: soundex.pbl ' Zweck: Phonetische Ähnlichkeit von Zeichenketten (Namen) beurteilen ' Stand: 11.12.94 ' Version: 1.00 ' Autor: (C) PC-Magazine USA; angepaßt M.Hoffmann ' Sprache: PowerBASIC 3.x '------------------------------------------------------------------------------ $com 0 $compile unit $cpu 80386 $debug map-,pbdebug-,path-,unit- $dim all $error bounds-,numeric-,overflow-,stack- $event off $float emulate $lib com-,lpt-,cga-,ega-,vga-,fullfloat-,iprint- $optimize size $option cntlbreak-,gosub-,signed- $sound 0 $stack &h800 $static $string 1 function soundex (text as string, count as integer) public as string dim word as local string dim code as local string dim snd as local string dim i as local integer dim e as local byte dim this as local string dim prev as local string dim l as local integer word = ucase$(Text$) do until instr(word,"Ä") = 0 replace "Ä" with "AE" in word loop do until instr(word,"Ö") = 0 replace "Ö" with "OE" in word loop do until instr(word,"Ü") = 0 replace "Ü" with "UE" in word loop do until instr(word,"ß") = 0 replace "ß" with "SS" in word loop code = "01230120022455012623010202" rem -> "abcdefghijklmnopqrstuvwxyz" ' snd = left$(word,1) Originalcodierung: 1.Zeichen zurückgeben if count = 0 then l = len(word) else l = count end if for i=1 to len(word) ' Original: i=2 e = ascii(mid$(word,i,1))-64 if e > 0 and e < 27 then this = mid$(code,e,1) if ascii(this) <> 0 and this <> prev then snd = snd+this prev = this end if end if next i soundex = left$(snd,l) ' Original: left$(snd+"0000",l) end function