PureBasic Forums - English

Code: Select all

function Remove-Diacritics {
    param ([String]$src = [String]::Empty)
    $normalized = $src.Normalize( [Text.NormalizationForm]::FormD )
    $sb = new-object Text.StringBuilder
    $normalized.ToCharArray() | ForEach-Object { 
        if( [Globalization.CharUnicodeInfo]::GetUnicodeCategory($PSItem) -ne [Globalization.UnicodeCategory]::NonSpacingMark) {
            [void]$sb.Append($PSItem)
        }
    }
    $sb.ToString()
}

Code: Select all

#NormalizationOther = 0
#NormalizationC = 1
#NormalizationD = 2
#NormalizationKC = 5
#NormalizationKD = 6

; https://learn.microsoft.com/en-us/windows/win32/api/stringapiset/nf-stringapiset-getstringtypew
Import "Kernel32.lib"
  GetStringTypeW.l(dwInfoType.l, *lpSrcStr, cchSrc.l, *lpCharType)
EndImport

; https://learn.microsoft.com/en-us/windows/win32/api/winnls/nf-winnls-normalizestring
Import "Normaliz.lib"
  NormalizeString.l(NormForm.l, SrcString.s, cwSrcLength.l, *lpDstString, cwDstLength.l)
EndImport


Structure ca
  c.c[0]
EndStructure

Procedure.s RemoveDiacritics(String$)
  Protected i, len = Len(String$)
  Protected *buffer.ca
  Protected Result$
  
  If len = 0 : ProcedureReturn "" : EndIf
  
  len = NormalizeString(#NormalizationD, String$, -1, 0, 0)
  If len > 0
    *buffer = AllocateMemory(len * SizeOf(Character))
    If *buffer
      len = NormalizeString(#NormalizationD, String$, -1, *buffer, len)
      If len > 1
        len - 1
        
        Protected Dim type.u(len)
        
        If GetStringTypeW(#CT_CTYPE3, *buffer, len, @type())
          
          For i = 0 To len
            If type(i) & (#C3_DIACRITIC | #C3_NONSPACING) = 0
              Result$ + Chr(*buffer\c[i])
            EndIf
          Next
          
        EndIf
      EndIf
      FreeMemory(*buffer)
    EndIf
  EndIf
  ProcedureReturn Result$
EndProcedure

Debug RemoveDiacritics("ñññ")
Debug RemoveDiacritics("ÅÅÅ")

Code: Select all

Procedure.s ReplaceAccent(Texte.s)
  Protected i, Char.s
  For i = 1 To Len(Texte)
    Char = Mid(Texte, i, 1)
    Select LCase(Char)
      Case "é", "è", "ê", "ë"
        ReplaceString(Texte, Char, "e", #PB_String_InPlace)
      Case "à", "ä", "â"
        ReplaceString(Texte, Char, "a", #PB_String_InPlace)
      Case "ù", "ü", "û"
        ReplaceString(Texte, Char, "u", #PB_String_InPlace)
      Case "ï", "î"
        ReplaceString(Texte, Char, "i", #PB_String_InPlace)
      Case "ô", "ö"
        ReplaceString(Texte, Char, "o", #PB_String_InPlace)
    EndSelect
  Next i
  ProcedureReturn Texte
EndProcedure  

Code: Select all

Procedure ReplaceAccent(*c.Character)
	If *c = 0 Or *c\c = 0
		ProcedureReturn 0
	EndIf
	
	While *c\c
		Select *c\c
			Case 'é', 'è', 'ê', 'ë'
				*c\c = 'e'
			Case 'à', 'ä', 'â'
				*c\c = 'a'
			Case 'ù', 'ü', 'û'
				*c\c = 'u'
			Case 'ï', 'î'
				*c\c = 'i'
			Case 'ô', 'ö'
				*c\c = 'o'
			Case 'É', 'È', 'Ê', 'Ë'
				*c\c = 'E'
			Case 'À', 'Ä', 'Â'
				*c\c = 'A'
			Case 'Ù', 'Ü', 'Û'
				*c\c = 'U'
			Case 'Ï', 'Î'
				*c\c = 'I'
			Case 'Ô', 'Ö'
				*c\c = 'O'
		EndSelect
		*c + SizeOf(Character)
	Wend
EndProcedure

tmp.s="dféöке'É', 'È', 'Ê', 'Ë"
ReplaceAccent(@tmp)
Debug tmp

Code: Select all

Procedure ReplaceAccent(*c.Character)
	If *c = 0 Or *c\c = 0
		ProcedureReturn 0
	EndIf
	
	While *c\c
		Select *c\c
			Case 'è' To 'ë'	; 232-235
				*c\c = 'e'
			Case 'à' To 'å' ; 224-229
				*c\c = 'a'
			Case 'ù' To 'ü'	; 249-252
				*c\c = 'u'
			Case 'ì' To 'ï'	; 236-239
				*c\c = 'i'
			Case 'ò' To 'ö'	; 242-246
				*c\c = 'o'
			Case 'È' To 'Ë' ; 200-203
				*c\c = 'E'
			Case 'À' To 'Å' ; 192-197
				*c\c = 'A'
			Case 'Ù' To 'Ü' ; 217-220
				*c\c = 'U'
			Case 'Ì' To 'Ï' ; 204-207
				*c\c = 'I'
			Case 'Ò' To 'Ö' ; 210-214
				*c\c = 'O'
		EndSelect
		*c + SizeOf(Character)
	Wend
EndProcedure

Define tmp.s="dféöке'É', 'È', 'Ê', 'Ë"
ReplaceAccent(@tmp)
Debug tmp

Code: Select all

Procedure.s ReplaceAccents(String$)
  Protected *c.Character
  
  *c = @String$  
  If *c 	
    While *c\c
      If *c\c >= 192   ; Accents start at 192 with 'À'           
        Select *c\c
          Case 192 To 198   ; 'A' with different accents
            *c\c = 'A'
          Case  224 To 230
            *c\c = 'a'
            
          Case 200 To 203   ; 'E' with different accents
            *c\c = 'E'           
          Case 232 To 235
            *c\c = 'e'
            
          Case 204 To 207   ; 'I' with different accents
            *c\c = 'I'
          Case 236 To 239
            *c\c = 'i'
            
          Case 210 To 214   ; 'O' with different accents
    				*c\c = 'O'
          Case 242 To 246
    				*c\c = 'o'
           
          Case 217 To 220   ; 'U' with different accents
    				*c\c = 'U'
          Case 249 To 252
    				*c\c = 'u'
    				
    		  Case 221          ; 'Y' with different accents
    			  *c\c = 'Y'
    			Case 253, 255
     				*c\c = 'y'
     				
     			Case 209          ;  'N' with different accents 
     				*c\c = 'N'
     			Case 241
      	    *c\c = 'n'
    			  
     		EndSelect
    	EndIf     	
    	*c + SizeOf(Character)
  	Wend
  EndIf
  ProcedureReturn String$
EndProcedure

tmp.s="dféöке'É', 'È', 'Ê', 'Ë"
res$ = ReplaceAccents(tmp)
Debug res$

Code: Select all

Procedure StrStripAccents_(*in.Unicode)  ;changes the case of the string inplace 
    
    Protected *char.Unicode,tchar.u 
    *char = *in 
    While *char\u  
      If casemappingCD(*char\u)\cdl <> 0 
        *char\u = casemappingCD(*char\u)\cdl 
      EndIf 
      *char+2 
    Wend 
    
  EndProcedure  
  
  StrStripAccents = @StrStripAccents_() ;prototype so you pass in string without Address = no copy or need to parse the string for its length 

Code: Select all

  Procedure.s RemoveAccents(Text$)
    ; Function to remove accents from a string. By Zapman.
    If Text$
      Protected length = Len(Text$) * 2
      Protected char$, ct, Result$
      Protected NormalizedText$ = Space(Length)
      ;
      Length = FoldString_(#MAP_COMPOSITE, @Text$, - 1, @NormalizedText$, Length) - 1
      ;
      If Length > 0 And Length <> Len(Text$)
        For ct = 1 To Length
          char$ = Mid(NormalizedText$, ct, 1)
          If Asc(char$) < 128
            Result$ + char$
          EndIf
        Next
      Else
        Result$ = Text$
      EndIf
      ;
      ProcedureReturn Result$
    EndIf
  EndProcedure

Code: Select all

Procedure.s RemoveAccents(Text$)
    ; Function to remove accents from a string. By Zapman.
    If Text$
      Protected length = Len(Text$) * 2
      Protected Ochar$, Nchar$, OPos, NPos, Result$
      Protected NormalizedText$ = Space(Length)
      ;
      ; FoldString_() will replace each accentuated character by a pair of characters
      ; as this: (NonAccentuatedCharacter) + (diacritic)
      Length = FoldString_(#MAP_COMPOSITE, @Text$, - 1, @NormalizedText$, Length) - 1
      ;
      ; Examine the result:
      If Length > 0 And Length <> Len(Text$)
        For NPos = 1 To Length
          OPos + 1
          Ochar$ = Mid(Text$, OPos, 1)
          Nchar$ = Mid(NormalizedText$, NPos, 1)
          Result$ + Nchar$
          If Ochar$ <> Nchar$
            ; If the character has been replaced, it means that the following character
            ; contains the diacritic. Jump over it:
            NPos + 1
          EndIf
        Next
      Else
        ; No replacement has been made.
        Result$ = Text$
      EndIf
      ;
      ProcedureReturn Result$
    EndIf
  EndProcedure
  
  Debug "Demo: ''Hétérogène'' --> ''" + RemoveAccents("Hétérogène") + "''."