Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0207: Verfügbare Codepages auslesen

VB 5/6-Tipp 0207: Verfügbare Codepages auslesen

 von ActiveVB

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMemory), EnumSystemCodePagesA (EnumSystemCodePages), GetCPInfo

Download: Download des Beispielprojektes [3,29 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Optionsfeld-Steuerelement "Option1" (Index von 0 bis 1)
' Steuerelement: Listen-Steuerelement "List1"
Option Explicit

Private Sub Option1_Click(Index As Integer)
  Call EnumCodePage(Index, List1)
End Sub

Private Sub Form_Load()
  Option1(0).Value = True
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Private Declare Function EnumSystemCodePages Lib "kernel32" _
        Alias "EnumSystemCodePagesA" (ByVal _
        lpCodePageEnumProc As Long, ByVal dwFlags As Long) _
        As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (Destination As Any, Source As Any, _
        ByVal Length As Long)

Private Declare Function GetCPInfo Lib "kernel32" (ByVal _
        CodePage As Long, lpCPInfo As CPINFO) As Long

Const CP_INSTALLED = &H1
Const CP_SUPPORTED = &H2

Const MAX_DEFAULTCHAR = 2
Const MAX_LEADBYTES = 12

Type CPINFO
  MaxCharSize As Long
  DefaultChar(MAX_DEFAULTCHAR) As Byte
  LeadByte(MAX_LEADBYTES) As Byte
End Type

Dim CP() As Long

Public Sub EnumCodePage(Mode%, LB As ListBox)
  Dim x%, aa$, Flag&, Result&, CPInf As CPINFO
    
    Select Case Mode
      Case 0:    Flag = CP_INSTALLED
      Case 1:    Flag = CP_SUPPORTED
      Case Else: Flag = 0
    End Select
    
    If Flag Then
      ReDim CP(0 To 0)
      LB.Clear
      Call EnumSystemCodePages(AddressOf CodePageEnumProc, Flag)
      For x = 0 To UBound(CP) - 1
        Result = GetCPInfo(CP(x), CPInf)
        aa = CP(x) & " " & CPInf.MaxCharSize & " " _
             & GetCodePageString(CP(x))

        LB.AddItem aa
      Next x
    Else
      MsgBox ("Diese Option wird nicht unterstützt!")
    End If
End Sub

Private Function CodePageEnumProc(CP_Pointer&) As Long
  Dim Buffer$
  
    Buffer = Space$(255)
    Call CopyMemory(ByVal Buffer, CP_Pointer, Len(Buffer))
    Buffer = Left$(Buffer, InStr(Buffer, Chr$(0)) - 1)
    CP(UBound(CP)) = CLng(Buffer)
    ReDim Preserve CP(0 To UBound(CP) + 1)
    CodePageEnumProc = 1&
End Function

Private Function GetCodePageString(CP&) As String
  Dim aa$
    
    Select Case CP
      Case 37:    aa = "EBCDIC"
      Case 437:   aa = "MS-DOS United States"
      Case 500:   aa = "EBCDIC 500V1"
      Case 708:   aa = "Arabic (ASMO 708)"
      Case 709:   aa = "Arabic (ASMO 449+, BCON V4)"
      Case 710:   aa = "Arabic (Transparent Arabic)"
      Case 720:   aa = "Arabic (Transparent ASMO)"
      Case 737:   aa = "Greek (formerly 437G)"
      Case 775:   aa = "Baltic"
      Case 850:   aa = "MS-DOS Multilingual (Latin I)"
      Case 852:   aa = "MS-DOS Slavic (Latin II)"
      Case 855:   aa = "IBM Cyrillic (primarily Russian)"
      Case 857:   aa = "IBM Turkish"
      Case 860:   aa = "MS-DOS Portuguese"
      Case 861:   aa = "MS-DOS Icelandic"
      Case 862:   aa = "Hebrew"
      Case 863:   aa = "MS-DOS Canadian-French"
      Case 864:   aa = "Arabic"
      Case 865:   aa = "MS-DOS Nordic"
      Case 866:   aa = "MS-DOS Russian"
      Case 869:   aa = "IBM Modern Greek"
      Case 874:   aa = "Thai"
      Case 875:   aa = "EBCDIC"
      Case 932:   aa = "Japan"
      Case 936:   aa = "Chinese (PRC, Singapore)"
      Case 949:   aa = "Korean"
      Case 850:   aa = "Chinese (Taiwan, Hong Kong"
      Case 1026:  aa = "EBCDIC"
      Case 1200:  aa = "Unicode (BMP of ISO 10646)"
      Case 1250:  aa = "Windows 3.1 Eastern European"
      Case 1251:  aa = "Windows 3.1 Cyrillic"
      Case 1252:  aa = "Windows 3.1 US (ANSI)"
      Case 1253:  aa = "Windows 3.1 Greek"
      Case 1254:  aa = "Windows 3.1 Turkish"
      Case 1255:  aa = "Hebrew"
      Case 1256:  aa = "Arabic"
      Case 1257:  aa = "Baltic"
      Case 1361:  aa = "Korean (Johab)"
      Case 10000:  aa = "Macintosh Roman"
      Case 10001:  aa = "Macintosh Japanese"
      Case 10006:  aa = "Macintosh Greek I"
      Case 10007:  aa = "Macintosh Cyrillic"
      Case 10029:  aa = "Macintosh Latin 2"
      Case 10079:  aa = "Macintosh Icelandic"
      Case 10081:  aa = "Macintosh Turkish"
      Case Else: aa = "Nicht definiert!"
    End Select
    
    GetCodePageString = aa
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.