Discussion :

[Papy214]

J'ai codé ça rapidement en FMX sous Delphi Berlin et ça fonctionne.
Alors, pourquoi ne pas en faire profiter la communauté ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
function NoAccent(const Source: string): string;
var
 K: TArray<Byte>;
begin
  K := TEncoding.Convert(TEncoding.Unicode, TEncoding.ASCII, TEncoding.Unicode.GetBytes(Source));
  Result := StringOf(K);
end;
 
procedure TForm24.Button1Click(Sender: TObject);
begin
  ShowMessage(NoAccent('Éùéèàçùâêûî'));
end;

Résultat

---------------------------
Project5
---------------------------
Eueeacuaeui
---------------------------
OK
---------------------------

[Cirec]

Bonjour,

simple et fonctionnel Bravo !

Avant l'arrivée le l'UNICODE et de la classe TEncoding j'avais également "pondu" une fonction de ce type
le plus sympas dans l'histoire c'est qu'elle est compatible de D7 à Tokyo 10.2
pour ceux que ça intéresse de voir une approche différente voici le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 
function RemoveAccent(const S: string): string;
const
  ATC          : array[$C0..$DF] of Byte = ($41, $41, $41, $41, $41, $41, $41,
                                            $43, $45, $45, $45, $45, $49, $49,
                                            $49, $49, $44, $4E, $4F, $4F, $4F,
                                            $4F, $4F, $4F, $4F, $55, $55, $55,
                                            $55, $59, $42, $59);
var
  pbResult        : PByte;
begin
  Result := S;
  pbResult := PByte(Result);
  while pbResult^ <> $0 do begin
    if pbResult^ > $7A then
      case pbResult^ of
        $8A: pbResult^ := $53;
        $8E: pbResult^ := $5A;
        $9E: pbResult^ := $7A;
        $9F: pbResult^ := $59;
        $C0..$DF: pbResult^ := ATC[pbResult^];
        $E0..$FF: pbResult^ := ATC[pbResult^ xor $20] xor $20;
      end;
    Inc(pbResult, SizeOf(Char));
  end;
end;
 
 
procedure TForm1.Button1Click(Sender: TObject);
const
  accent         : string = 'Essai de ÀÁÂÃÄÅàáâãäåÒÓÔÕÖØòóôõöøÈÉÊËèéêëÌÍÎÏìíîïÙÚÛÜùúûüÿÑñÇç';
begin
  ShowMessage(RemoveAccent(accent));
end;

Resultat:
[Window Title]
Project1
[Content]
Essai de AAAAAAaaaaaaOOOOOOooooooEEEEeeeeIIIIiiiiUUUUuuuuyNnCc
[OK]
Cordialement,
@+

[Jipété]

je ne vois pas trop l'intérêt, merci de m'expliquer.

[Cirec]

je ne vois pas trop l'intérêt, merci de m'expliquer.

Que répondre à cela ?
Ben l'intérêt de ce code, comme de tout code d'ailleurs, est de faire ce pourquoi il a été conçu !!
ici il doit supprimer les accents.

Si on te demande de supprimer les accents des noms de fichiers ou d'un titre quelconque (par Ex.) ou toutes autres raisons.
Ben ... tu le fais.
Bien sûr il n'est pas question "d'écrire" un texte avec mais il peut quand même avoir son utilité
Cordialement,
@+

[Andnotor]

Ça marche impec

Juste un soucis au niveau des ligatures qui ne sont pas préservées (œ, æ, ß, etc.)

Voici une version purement Windows qui explose la chaîne en symboles distincts (caractères et accents) avant de supprimer les accents, tout en conservant les ligatures :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
function NoAccent(const Source: string): string;
var
  i: Integer;
begin
  SetLength(Result, FoldString(MAP_COMPOSITE, PChar(Source), Length(Source), nil, 0));
  FoldString(MAP_COMPOSITE, PChar(Source), Length(Source), PChar(Result), Length(Result));
 
  for i := Length(Result) downto 1 do
    if Result[i].GetUnicodeCategory = TUnicodeCategory.ucNonSpacingMark then
      Delete(Result, i, 1);
end;

Et pour faire exploser les ligatures :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
function NoLigature(const Source: string): string;
begin
  SetLength(Result, FoldString(MAP_EXPAND_LIGATURES, PChar(Source), Length(Source), nil, 0));
  FoldString(MAP_EXPAND_LIGATURES, PChar(Source), Length(Source), PChar(Result), Length(Result));
end;

je ne vois pas trop l'intérêt, merci de m'expliquer.

Un système qui permet de faire facilement une aide à la saisie, de proposer une liste de mots indépendamment des accents (ou ligatures)

[guillemouze]

Intéressant, mais je ne comprend pas pourquoi il a cette réaction ... certes ils sont dans la partie étendue (>128), mais les accents sont bien présents en ASCII.
Dans ce cas, comment fais tu pour convertir une chaine simple avec un accent en ansi, tout en le conservant ?

[Andnotor]

Intéressant, mais je ne comprend pas pourquoi il a cette réaction ... certes ils sont dans la partie étendue (>128), mais les accents sont bien présents en ASCII.
Dans ce cas, comment fais tu pour convertir une chaine simple avec un accent en ansi, tout en le conservant ?

Ne pas confondre ASCII (les 127 premiers caractères) et ANSI (255)

Sinon, la conversion Unicode - ANSI est implicite en Delphi, ANSIStr := UnicodeStr suffit.

[Papy214]

En remplaçant ASCII par ANSI

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
function NoAccent(const Source: string): string;
var
 K: TArray<Byte>;
begin
  K := TEncoding.Convert(TEncoding.Unicode, TEncoding.ANSI, TEncoding.Unicode.GetBytes(Source));
  Result := StringOf(K);
end;

---------------------------
Project5
---------------------------
Éùéèàçùâêûî
---------------------------
OK
---------------------------

[Papy214]

Voici une version purement Windows qui explose la chaîne en symboles distincts (caractères et accents) avant de supprimer les accents, tout en conservant les ligatures :

purement Windows à cause de ? la fonction FoldString ??

[foetus]

Dans ce cas, comment fais tu pour convertir une chaine simple avec un accent en ansi, tout en le conservant ?

Ce sont les APIs Microsoft qui fait le fallback

[Andnotor]

purement Windows à cause de ? la fonction FoldString ??

C'est ça, un appel direct à une API Windows.

[ShaiLeTroll]

je ne vois pas trop l'intérêt, merci de m'expliquer.

C'est utile pour des systèmes type Moteur de Recherche, en tout cas c'est ainsi que je l'ai appliqué sur un dictionnaire médicale de 800000 mots et comme Andnotor,
très attaché ligatures pour les mots comme œdème ou cœur (qu'il faut pouvoir trouvé en version ligaturée ou déliée)

Merci de ce partage

Dire que l'on faisait tout ça il y a dix ans, en été 2007 : https://www.developpez.net/forums/d3...lever-accents/
ou encore https://www.developpez.net/forums/d4...g/#post2765158

[Cirec]

... et comme Andnotor,
très attaché ligatures pour les mots comme œdème ou cœur (qu'il faut pouvoir trouvé en version ligaturée ou déliée) ...

pour une simple comparaison/recherche j'utilise ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
var
  dwCmpFlags        : Cardinal;
  Str1, Str2        : string;
begin
  Str1 := 'Coeur Biß œdème';
  Str2 := 'cœur biss oedeme';
  dwCmpFlags := NORM_IGNORECASE or NORM_IGNORENONSPACE or NORM_IGNORESYMBOLS;
  if CompareString(LOCALE_USER_DEFAULT, dwCmpFlags, PChar(Str1), -1,
    PChar(Str2), -1) = CSTR_EQUAL then ShowMessage('Egale');

qui fonctionne très bien sans changer un seul caractère

Cordialement,
@+

[Andnotor]

Le but (pour moi) de simplifier la chaîne est de calculer un hash unique quelque soit les variations de saisie. Après, on peut bien sûr utiliser CompareString sur les collisions.

[retwas]

Merci pour le code qui est effectivement utile pour enregistrer des fichiers ou autre.

@Cirec pour comparer tu peux utiliser le Soundex

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

function Soundex(const AText: string; ALength: TSoundexLength): string;

[Cirec]

@Andnotor:
en fait j'avais bien compris l'utilité de retirer les accents
le code CompareString était destiné à ShaiLeTroll en réponse à

... pour les mots comme œdème ou cœur (qu'il faut pouvoir trouvé en version ligaturée ou déliée)

@retwas:

SoundEx me pose quelques problèmes !! Ex.

avec CompareString : 'Coeur Biß œdème' == 'cœur biss oedeme'
avec SoundEx : 'Coeur Biß œdème' <> 'cœur biss oedeme'

et mot par mot ça donne (toujours avec SoundEx)
'Coeur' == 'cœur'
'Biß' <> 'biss'
'œdème' <> 'oedeme'

Je vais donc conserver CompareString pour l'instant

Cordialement,
@+

[SergioMaster]

Bonjour,

le problème de soundex est qu'il est anglophone et non multilingue comme on devrait s'y attendre. Fut un temps j'avais réussi à modifier un algorithme pour le rendre francophone mais le ß ne serait pas passé non plus. A ma souvenance, mais ce sont de vieux souvenirs, une des première chose que fait l'algorithme de soundex est d'ôter certaines voyelles selon certaines conditions par exemple si elles se trouvent après une consonne par contre je ne me souviens plus de ce qui se passe pour des voyelles doublées.

par curiosité je vais faire un essai : tee,tye,Eti,tea,été ....

[Jipété]

[...] des voyelles doublées.

par curiosité je vais faire un essai : tee,tye,Eti,tea,été ....

Essaye avec oiseau, créées,

[SergioMaster]

ma curiosité ne m'a pas perdue et même remis en mémoire certaines choses
la premier caractère est toujours pris tel quel et normalement en majuscule (j'insiste sur normalement car ce n'est pas le cas pour tout caractère hors ASCII)
ensuite seul les consonnes sont prises en compte et selon un "poids" << à mon avis c'est ici qu'entre en compte la langue

Utiliser le code de Papy214 ou de Cirec permettrait déjà une meilleure comparaison phonétique

pour ceux qui serait tenté par des tests

Source

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
unit UnitSoundex;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.StrUtils, System.Math;
 
type
  TForm8 = class(TForm)
    Texte1: TEdit;
    Texte2: TEdit;
    BtnSoundEx: TButton;
    RSoundEx: TLabel;
    Phonetic1: TLabel;
    Phonetic2: TLabel;
    procedure BtnSoundExClick(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;
 
var
  Form8: TForm8;
 
implementation
 
{$R *.dfm}
 
procedure TForm8.BtnSoundExClick(Sender: TObject);
var i : Integer;
begin
i:=Max(Length(Texte1.Text),Length(Texte2.Text));
Phonetic1.Caption:=Soundex(Texte1.Text,10); // uniquement les 10 premiers car
Phonetic2.Caption:=Soundex(Texte2.Text,10);
 
if SoundexSimilar(Texte1.text,Texte2.text,i) then RSoundex.Caption:='='
                                 else RSoundex.Caption:='<>'
 
end;
 
end.

+Dfm

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
object Form8: TForm8
  Left = 0
  Top = 0
  Caption = 'Form8'
  ClientHeight = 201
  ClientWidth = 447
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object RSoundEx: TLabel
    Left = 176
    Top = 45
    Width = 31
    Height = 13
    Caption = 'Label1'
  end
  object Phonetic1: TLabel
    Left = 271
    Top = 19
    Width = 31
    Height = 13
    Caption = 'Label1'
  end
  object Phonetic2: TLabel
    Left = 271
    Top = 72
    Width = 47
    Height = 13
    Caption = 'Phonetic2'
  end
  object Texte1: TEdit
    Left = 88
    Top = 16
    Width = 161
    Height = 21
    TabOrder = 0
    Text = 'Edit1'
  end
  object Texte2: TEdit
    Left = 88
    Top = 69
    Width = 161
    Height = 21
    TabOrder = 1
    Text = 'Edit2'
  end
  object BtnSoundEx: TButton
    Left = 88
    Top = 96
    Width = 75
    Height = 25
    Caption = 'BtnSoundEx'
    TabOrder = 2
    OnClick = BtnSoundExClick
  end
end