LISTER LES PAGES DE CODE SUPPORTÉES PAR WINDOWS

Option Explicit

' Call f_CodePage_Init() to feed the global varibales g_CodePageLst() and g_CodePageNbr
'  with the Code Pages supported by the current Windows installation.
' 2007-12-27, Skrol29

Private Const MAX_LEADBYTES = 12
Private Const MAX_DEFAULTCHAR = 2
Private Const MAX_PATH = 260

Private Type CPINFOEX
  MaxCharSize As Long ' max length (Byte) of a char
  DefaultChar(0 To MAX_DEFAULTCHAR - 1) As Byte ' default character
  LeadByte(0 To MAX_LEADBYTES - 1) As Byte ' lead byte ranges
  UnicodeDefaultChar As Byte
  CodePage As Long
  CodePageName(0 To MAX_PATH - 1) As Byte
End Type

Private Declare Function api_EnumSystemCodePages Lib "kernel32.dll" Alias "EnumSystemCodePagesA" (ByVal lpCodePageEnumProc As Long, ByVal dwFlags As Long) As Long
Private Declare Sub api_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function api_GetCPInfoEx Lib "kernel32" Alias "GetCPInfoExA" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpCPInfoEX As CPINFOEX) As Long

' EnumSystemCodePages
Const CP_INSTALLED = &H1
Const CP_SUPPORTED = &H2

Public Type tCodePage
  Id As Long
  Name As String
End Type
Public g_CodePageLst() As tCodePage
Public g_CodePageNbr As Long

Public Sub f_CodePage_Init()

  If g_CodePageNbr > 0 Then Exit Sub
  
  ' Call the CallBack as much time as there are CodePage
  api_EnumSystemCodePages AddressOf f_CodePage_CallBack, CP_INSTALLED


End Sub

Public Function f_CodePage_CallBack(CP_Pointer As Long) As Long
' Returns TRUE to continue enumeration or FALSE otherwise.

  Dim Buffer As String
  Dim Id As Long
  Dim x As String
  Dim CodePage As tCodePage
  
  Buffer = Space$(255)
  Call api_CopyMemory(ByVal Buffer, CP_Pointer, Len(Buffer))
  Buffer = Left$(Buffer, InStr(Buffer, Chr$(0)) - 1)

  CodePage.Id = Val(Buffer)
  
  If CodePage.Id > 0 Then
    ' Save the CodePage is the list
    CodePage.Name = f_CodePage_Name(CodePage.Id)
    ReDim Preserve g_CodePageLst(0 To g_CodePageNbr)
    g_CodePageLst(g_CodePageNbr) = CodePage
    g_CodePageNbr = g_CodePageNbr + 1
  End If
  
  f_CodePage_CallBack = 1

End Function

Public Function f_CodePage_Name(Id As Long) As String

  Dim CpInfo As CPINFOEX
  Dim x As String
  Dim i As Integer
  Dim ok As Boolean
  
  Call api_GetCPInfoEx(Id, 0, CpInfo)
  
  With CpInfo
  
    ' Retrieve the full name
    i = LBound(.CodePageName)
    ok = True
    Do While ok And (i <= UBound(.CodePageName))
      If .CodePageName(i) = 0 Then
        ok = False
      Else
        x = x & Chr$(.CodePageName(i))
        i = i + 1
      End If
    Loop
    
    ' Take of the number. Names can be formated like "1234 (name)"
    i = InStr(x, "(")
    If (.CodePage > 0) And (i > 0) And (Right(x, 1) = ")") Then
      If Val(Left$(x, i - 1)) = .CodePage Then
        x = Mid$(x, i + 1)
        x = Left$(x, Len(x) - 1)
      End If
    End If
    
    ' If no name => display the id
    If x = vbNullString Then
      x = "{" & .CodePage & "}"
    End If
    
  End With
  
  f_CodePage_Name = x
  
End Function