Attribute VB_Name = "Unicode"
Option Explicit

Public Const CP_ACP = 0
Public Const CP_UTF8 = 65001

Private Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004

Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal Codepage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Any, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal Codepage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, lpUsedDefaultChar As Long) As Long

Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long

Private Declare Function GetACP Lib "kernel32.dll" () As Long

Public Function TextWW(Text As String, DC As Long) As Long
  Dim TextSize As POINTAPI
  GetTextExtentPoint32 DC, Text, Len(Text), TextSize
  TextWW = TextSize.X
End Function

Public Sub IntBasicCodepage()
  BasicCodepage = GetACP '<-
  'BasicCodepage = 932 'Chinesisch
End Sub

Public Function GetInputCodepage() As Long
  Dim Ret As Long
  Dim Buffer As String
  
  Buffer = String(32, 0)
  Ret = GetLocaleInfo(LoWord(GetKeyboardLayout(0)), LOCALE_IDEFAULTANSICODEPAGE, Buffer, Len(Buffer))
  If Ret > 0 Then
    GetInputCodepage = Val(Left(Buffer, Ret - 1))
    'GetInputCodepage = 936 'Chinesisch
    'GetInputCodepage = 932 'Japanisch
  End If
End Function

Public Function GetCharSetByCP(Codepage As Long) As Long
  Select Case Codepage
    Case 932:  GetCharSetByCP = 128
    Case 949:  GetCharSetByCP = 129
    Case 1351: GetCharSetByCP = 130
    Case 936:  GetCharSetByCP = 134
    Case 950:  GetCharSetByCP = 136
    Case 1253: GetCharSetByCP = 161
    Case 1254: GetCharSetByCP = 162
    Case 1255: GetCharSetByCP = 177
    Case 1256: GetCharSetByCP = 178
    Case 1257: GetCharSetByCP = 186
    Case 1251: GetCharSetByCP = 204
    Case 874:  GetCharSetByCP = 222
    Case 1250: GetCharSetByCP = 238
    Case 437:  GetCharSetByCP = 254
'    Case 54936:  GetCharSetByCP = 1
    Case Else: GetCharSetByCP = 0
  End Select
End Function

Public Function ConvMsgToUnicode(Data() As Byte, FirstByte As Long, BuffLen As Long, Codepage As Long) As String
  If IsUTF8(Data, FirstByte, BuffLen) Then
    ConvMsgToUnicode = DecodeByteArr(Data, FirstByte, BuffLen, CP_UTF8)
  Else
    ConvMsgToUnicode = DecodeByteArr(Data, FirstByte, BuffLen, Codepage)
  End If
End Function

Public Function ConvToUnicode(Data() As Byte, FirstByte As Long, BuffLen As Long, Codepage As Long, UTF8on As Boolean) As String
  If UTF8on Then
    ConvToUnicode = DecodeByteArr(Data, FirstByte, BuffLen, CP_UTF8)
  Else
    ConvToUnicode = DecodeByteArr(Data, FirstByte, BuffLen, Codepage)
  End If
End Function

Public Function ConvToSend(Text As String, UTF8activ As Integer, UTF8static As Boolean, Optional MsgText As Boolean) As String
  If MsgText Then
    If UTF8activ = 1 Then
      ConvToSend = EncodeUTF8(Text)
    Else
      ConvToSend = UnicodeToANSI(Text, InputCodepage)
    End If
  Else
    If UTF8static Then
      ConvToSend = EncodeUTF8(Text)
    Else
      ConvToSend = UnicodeToANSI(Text, BasicCodepage)
    End If
  End If
End Function

Public Function ConvForDebug(Data() As Byte, FirstByte As Long, BuffLen As Long) As String
  Dim I As Long
  Dim OutBuff As String
  Dim LastC As Boolean
  
  For I = FirstByte To BuffLen + FirstByte - 1
    Select Case Data(I)
      Case 0 To 31, 128 To 255
        OutBuff = OutBuff + Chr(22) + IIf(LastC, "", " ") + CStr(Data(I)) + " " + Chr(15)
        LastC = True
      Case Else
        OutBuff = OutBuff + ChrW(Data(I))
        LastC = False
    End Select
  Next
  ConvForDebug = OutBuff
End Function

Public Function ConvForDebugStr(Text As String) As String
  Dim BBuffer() As Byte
  ReDim BBuffer(Len(Text))
  MemCopy BBuffer(0), Text, Len(Text)
  ConvForDebugStr = ConvForDebug(BBuffer, 0, Len(Text))
End Function

Public Function UnicodeToANSI(Text As String, Codepage As Long) As String
  Dim sStrOut As String
  Dim cwch As Long
  
  cwch = WideCharToMultiByte(Codepage, 0, StrPtr(Text), -1, ByVal 0&, 0&, ByVal 0&, ByVal 0&)
  sStrOut = String(cwch + 1, vbNullChar)
  cwch = WideCharToMultiByte(Codepage, 0, ByVal StrPtr(Text), Len(Text), ByVal sStrOut, cwch, ByVal 0&, ByVal 0&)
  If cwch > 0 Then UnicodeToANSI = Left(sStrOut, cwch)
End Function

Public Function ANSIToUnicode(Text As String, ByVal CharSet As Long) As String
  Dim stBuffer As String
  Dim cwch As Long
  Dim tBuff() As Byte
  
  If Len(Text) Then
    cwch = MultiByteToWideChar(CharSet, 0, ByVal Text, -1, 0&, 0&)
    stBuffer = String(cwch + 1, vbNullChar)
    cwch = MultiByteToWideChar(CharSet, 0, ByVal Text, Len(Text), StrPtr(stBuffer), cwch + 1)
    If cwch > 0 Then ANSIToUnicode = Left(stBuffer, cwch)
  End If
End Function

Public Function MakeUserID(Nick As String)
  Dim I As Integer
  Dim DAT As String
  
  For I = 1 To Len(Nick)
    If AscW(Mid(Nick, I, 1)) < 256 Then DAT = DAT + Mid(Nick, I, 1)
  Next
  If Len(DAT) < 3 Then DAT = "user" + DAT
  MakeUserID = LCase(DAT)
End Function

Public Function IsUTF8(Data() As Byte, FirstByte As Long, BuffLen As Long) As Boolean
  Dim I As Integer
  Dim I2 As Integer
  Dim uftFound As Boolean
  Dim CharVal As Long
  Dim Divider As Long
  
  Divider = 128
  For I = FirstByte To FirstByte + BuffLen
    CharVal = Data(I)
    If I2 = 0 Then
      Do While CharVal \ Divider
        CharVal = CharVal - Divider
        Divider = Divider \ 2
        I2 = I2 + 1
        If I2 > 4 Then Exit Function
      Loop
      If I2 > 0 Then
        If I2 = 1 Then Exit Function
        I2 = I2 - 1
        Divider = 128
      End If
    Else
      I2 = I2 - 1
      If CharVal \ 128 = 0 Or (CharVal - 128) \ 64 > 0 Then
        Exit Function
      End If
      uftFound = True
    End If
  Next
  IsUTF8 = uftFound And I2 = 0
End Function

Public Function EncodeUTF8(ByVal Text As String) As String
  Dim stBuffer As String
  Dim cwch As Long
  Dim pwz As Long
  
  pwz = StrPtr(Text)
  cwch = WideCharToMultiByte(CP_UTF8, 0, pwz, -1, ByVal 0&, 0&, ByVal 0&, ByVal 0&)
  stBuffer = String(cwch + 1, vbNullChar)
  cwch = WideCharToMultiByte(CP_UTF8, 0, pwz, -1, ByVal stBuffer, cwch + 1, ByVal 0&, ByVal 0&)
  If cwch > 0 Then EncodeUTF8 = Left(stBuffer, cwch - 1)
End Function

Public Function DecodeUTF8(ByVal Text As String) As String
  Dim stBuffer As String
  Dim cwch As Long
    
  If Len(Text) Then
    cwch = MultiByteToWideChar(CP_UTF8, 0, ByVal Text, -1, 0&, 0&)
    stBuffer = String(cwch + 1, vbNullChar)
    cwch = MultiByteToWideChar(CP_UTF8, 0, ByVal Text, -1, StrPtr(stBuffer), cwch + 1)
    If cwch > 0 Then DecodeUTF8 = Left(stBuffer, cwch - 1)
  End If
End Function

Public Function DecodeByteArr(Data() As Byte, FirstByte As Long, BuffLen As Long, CharSet As Long) As String
  Dim stBuffer As String
  Dim cwch As Long
    
  If BuffLen > 0 Then
    cwch = MultiByteToWideChar(CharSet, 0, Data(FirstByte), BuffLen, 0&, 0&)
    stBuffer = String(cwch, vbNullChar)
    cwch = MultiByteToWideChar(CharSet, 0, Data(FirstByte), BuffLen, StrPtr(stBuffer), cwch)
    'If cwch > 0 Then DecodeByteArr = Left(stBuffer, cwch)
    DecodeByteArr = stBuffer
  End If
End Function

Public Function EncodeToByteArr(SrcText As String, Data() As Byte, FirstByte As Long, CharSet As Long) As Long
  Dim pwz As String
  Dim cwch As Long
    
  If Len(SrcText) > 0 Then
    pwz = StrPtr(SrcText)
    cwch = WideCharToMultiByte(CharSet, 0, pwz, -1, ByVal 0&, 0&, ByVal 0&, ByVal 0&)
    If cwch + FirstByte > UBound(Data) - 1 Then
      ReDim Preserve Data(cwch + FirstByte - 1)
    End If
    cwch = WideCharToMultiByte(CharSet, 0, pwz, -1, Data(FirstByte), cwch, ByVal 0&, ByVal 0&)
  End If
  EncodeToByteArr = cwch - 1
End Function
