Fórum UDF PARA IMPLEMENTAR SOUNDEX PORTUGUES #37197

O código da função no delphi para criar a dll é assim:


function Soundex(Str: Pchar) : Pchar; cdecl; export;
var
Aux : String;
posicao : integer;
x : integer;
begin
Aux := TiraAcentos(Str); //Retirando os acentos
Aux := Trim(Aux); // Retirando os espaços iniciais e finais

{Excluindo caracteres duplicados
Exemplo.: Wellington = Welington}
for x:=1 to length(Aux) do
if x < length(Aux) then
if Copy(Aux,x,1) = Copy(Aux,x+1,1) then
delete (Aux,x,1);

{Trocando todos os W por V
Ex.: Waldir = Valdir }
posicao := Pos(´W´,Aux);
while Pos(´W´,Aux) > 0 do
begin
Delete(Aux,posicao,1);
Insert(´V´,Aux,posicao);
posicao := Pos(´W´,Aux);
end;


{Quando U for inicio da palavra e a letra seguinte for vogal
troca-se por V
Ex.: WELLINGTON = UELLINGTON}
posicao := Pos(´U´,Aux);
while (posicao > 0) and (posicao = 1) and (Pos(Copy(Aux,posicao+1,1),´AEIOU´) > 0) do
begin
Delete(Aux, posicao,1);
Insert(´V´,Aux, posicao);
posicao := Pos(´U´,Aux);
end;

{Trocando Y por I
Ex.: YOLANDA = IOLANDA}
posicao := Pos(´Y´,Aux);
while posicao > 0 do
begin
Delete(Aux,posicao,1);
Insert(´I´,Aux,posicao);
posicao := Pos(´Y´,Aux);
end;

{Quando C for inicio da palavra e a seguinte for EI
troca-se por S
Ex.: CELINA = SELINA}
posicao := Pos(´C´,Aux);
while (posicao > 0) and (posicao =1) and (Pos(Copy(Aux,posicao+1,1),´EI´)>0) do
begin
Delete(Aux,Posicao,1);
Insert(´S´,Aux,posicao);
posicao := Pos(´C´,Aux);
end;

{Troca-se K por C
Ex.: KARLA = CARLA}
posicao := Pos(´K´,Aux);
while posicao > 0 do
begin
Delete(Aux,Posicao,1);
Insert(´C´,Aux,posicao);
posicao := pos(´K´,Aux);
end;

{Troca-se PH por F
Ex.:´PHELIPE = FELIPE}
posicao := Pos(´PH´,Aux);
while posicao > 0 do
begin
Delete(Aux,Posicao,2);
Insert(´F´,Aux,posicao);
posicao := pos(´PH´,Aux);
end;

{Troca-se SCH por X, pois SCH tem som de X
Ex.: SCHIMENES = XIMENES}
posicao := Pos(´SCH´,Aux);
while posicao > 0 do
begin
Delete(Aux,posicao,3);
Insert(´X´,Aux,posicao);
posicao := pos(´SCH´,Aux);
end;

{Troca-se CH por X
Ex.: CHICO = XICO}
posicao := Pos(´CH´,Aux);
while posicao > 0 do
begin
Delete(Aux,posicao,2);
Insert(´X´,Aux,Posicao);
posicao := pos(´CH´,Aux);
end;

{Troca-se SH por X, pois tbém tem som de X}
posicao := Pos(´SH´,Aux);
while posicao > 0 do
begin
Delete(Aux,posicao,2);
Insert(´X´,Aux, posicao);
posicao := pos(´SH´,Aux);
end;

{Troca-se Z por S quando terminar palavra
Ex.: Luiz = Luis}
for x:=1 to length(Aux) do
if Copy(Aux,x,1) = ´ ´ then
if Copy (Aux,x-1,1) = ´Z´ then
begin
delete (Aux,x-1,1);
insert(´S´,Aux,x-1);
end;

{Quando S estiver entre duas vogais tem som de Z
Ex.: Josimar = Jozimar}
for x:=1 to length(Aux) do
if (Copy(Aux,x,1) = ´S´) and (x <>1) and (x <> length(Aux)) then
if (Pos(Copy(Aux,x-1,1),´AEIOU´) > 0) and (Pos(Copy(Aux,x+1,1),´AEIOU´) > 0) then
begin
delete(Aux,x,1);
insert(´Z´,Aux,x);
end;

{Excluí-se H pois H não tem som fonético quando
inicia palavras
Ex.: Hilda = Ilda}
for x:=1 to length(Aux) do
if (Copy(Aux,x,1) = ´H´) and (x <> length(Aux)) then
if x =1 then
delete(Aux,x,1)
else
if (Copy(Aux,x-1,1) = ´ ´) then
delete(Aux,x,1);

{Troca-se QU por C}
posicao := Pos(´QU´,Aux);
while (posicao > 0) and (posicao = 1) do
begin
Delete(Aux,posicao,2);
Insert(´C´,Aux,Posicao);
end;

{Retira-se todas vogais}
posicao := Pos(´A´,Aux);
while posicao > 0 do
begin
delete(Aux,posicao,1);
posicao := pos(´A´,Aux);
end;

posicao := Pos(´E´,Aux);
while posicao > 0 do
begin
delete(Aux,posicao,1);
posicao := pos(´E´,Aux);
end;

posicao := Pos(´I´,Aux);
while posicao > 0 do
begin
delete(Aux,posicao,1);
posicao := pos(´I´,Aux);
end;

posicao := Pos(´O´,Aux);
while posicao > 0 do
begin
delete(Aux,posicao,1);
posicao := pos(´O´,Aux);
end;

posicao := Pos(´U´,Aux);
while posicao > 0 do
begin
delete(Aux,posicao,1);
posicao := pos(´U´,Aux);
end;

result := Pchar(Aux);
end;


function TiraAcentos(Palavra: PChar): PChar;
begin
Result := Palavra;
if Palavra = nil then
Exit;
while Palavra^ <> #0 do
begin
case Palavra^ of
´á´, ´â´, ´ã´, ´à´, ´ä´, ´å´,
´Á´, ´Â´, ´Ã´, ´À´, ´Ä´, ´Å´: Palavra^ := ´A´;
´é´, ´ê´, ´è´, ´ë´,
´É´, ´Ê´, ´È´, ´Ë´: Palavra^ := ´E´;
´í´, ´î´, ´ì´, ´ï´,
´Í´, ´Î´, ´Ì´, ´Ï´: Palavra^ := ´I´;
´ó´, ´ô´, ´õ´, ´ò´, ´ö´,
´Ó´, ´Ô´, ´Õ´, ´Ò´, ´Ö´: Palavra^ := ´O´;
´ú´, ´û´, ´ù´, ´ü´,
´Ú´, ´Û´, ´Ù´, ´Ü´: Palavra^ := ´U´;
´ç´, ´Ç´: Palavra^ := ´C´;
´ñ´, ´Ñ´: Palavra^ := ´N´;
´ý´, ´ÿ´, ´Ý´, ´Ÿ´: Palavra^ := ´Y´;
else
if Ord(Palavra^) > 127 then
Palavra^ := 32;
end;
Inc(Palavra);
end;
end;



O código para compilar no interbase é:
DECLARE EXTERNAL FUNCTION SOUNDEX
CSTRING(254) CHARACTER SET NONE
RETURNS CSTRING(254) CHARACTER SET NONE
ENTRY_POINT ´Soundex´ MODULE_NAME ´Nome_da_DLL´;