Dim MyUnicodeText As clsUnicodeText
Set MyUnicodeText = New clsUnicodeText
' Read Unicode Text from file txtFileName and display in TextBox1(0)
TextBox1(0).Text = MyUnicodeText.ReadUnicode(txtFileName)

Option Explicit
Private mDOMTextFile As DOMDocument ' Document Object Model
Private mXMLPath As String ' XML filename
Public Function ReadUnicode(TXMLPath)
' Read Unicode text from XML file
Dim objTextFileRoot As IXMLDOMElement
Set mDOMTextFile = New DOMDocument
' Remember the XML file name to update later
mXMLPath = TXMLPath
' Read the XML file and create a DOM
mDOMTextFile.Load mXMLPath
'start at the root element of the XML
Set objTextFileRoot = mDOMTextFile.documentElement
' Return the root node's text
ReadUnicode = objTextFileRoot.nodeTypedValue
End Function
Public Sub WriteUnicode(OutText, Optional TXMLPath)
' Update Unicode Text of same XML file or write to another XML file
If IsMissing(TXMLPath) Then
' Assign the Text to write out to the Root node of DOM
mDOMTextFile.documentElement.Text = OutText
' Update the XML file
mDOMTextFile.save mXMLPath
Else
' Read a dummy file to create a DOM
ReadUnicode GetLocalDirectory & "Dummy.xml"
' Assign the Text to write out to the Root node of DOM
mDOMTextFile.documentElement.Text = OutText
' Write the Text to the given XML file
mDOMTextFile.save TXMLPath
End If
End Sub

Function StringToString(Vowel1, Vowel2) As String
' Direct one-to-one character mapping from one encoding to another
Dim letter As String
Dim Text1 As String
Dim Text2 As String
Dim i, Pos
' Use Text1 to execute a litle faster than TextBox1(0)
Text1 = TextBox1(0).Text
' Iterate through each character of the from Text string
For i = 1 To Len(Text1)
letter = Mid(Text1, i, 1)
' Leave Carriage Return and Line Feed characters as is
If (letter = vbCr) Then
Text2 = Text2 & vbCr
ElseIf (letter = vbLf) Then
Text2 = Text2 & vbLf
Else
' Find position of character in the vowel list
Pos = InStr(Vowel1, letter)
If Pos <= 0 Then
' Not found - so do not map
Text2 = Text2 & letter
Else
' Found - so pick the corresponding character in the other vowel list
Text2 = Text2 & Mid(Vowel2, Pos, 1)
End If
End If
Next
StringToString = Text2
End Function

myWinsock.LocalPort = myPortNo
myWinsock.Listen

myWinsock.Connect TCPAddress, myPortNo

Private Sub myWinsock_ConnectionRequest(ByVal RequestID As Long)
' Pass the value of the requestID parameter to the Accept method.
myWinsock.Accept RequestID
End Sub

Private Sub myWinsock_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
' Read the incoming data
myWinsock.GetData strData, vbString
' Process message ....
' ....
End Sub

Private Sub Form_Load()
Set Winsck = New clsWinsock
' There's no need to supply the TCP address
' The port number is arbitrary, but must be the same in both Server and Client, eg: 102
'-------- Use the next three lines for a server.
Me.Caption = "Winsock Server"
Text1.Text = "Greeting from Server"
Call Winsck.MakeConnection(Winsock1, "", 102, True, Timer1, Timer2)
'-------------------------------------------END for Server
' You must supply the TCP address of the Server, eg: "192.168.0.1"
'-------- Use the next three lines for a client.
' Me.Caption = "Winsock Client"
' Text1.Text = "Hello Server, this is Client calling"
' Call Winsck.MakeConnection(Winsock1, "192.168.0.1", 102, False, Timer1, Timer2)
'-------------------------------------------END for Client
lblStatus.Caption = "No Connection"
End Sub

Public Sub MakeConnection(theWinsock, theTCPAddress, PortNo, beingAServer, Timer1, Timer2)
On Error Resume Next
Set myWinsock = theWinsock
Set DeadManTimer = Timer1 ' Use Timer1 as DeadManTimer
DeadManTimer.Enabled = False ' Disable DeadManTimer initially
DeadManTimer.Interval = 2000 ' 2 seconds
Set ReConnectTimer = Timer2 ' Use Timer2 as ReConnectTimer
ReConnectTimer.Enabled = False ' Disable ReConnectTimer initially
ReConnectTimer.Interval = 2000 ' 2 seconds
TCPAddress = theTCPAddress ' the address may also be the server computer name, i.e: "server01"
myPortNo = PortNo ' same Port No. must be used for both server and client
IamServer = beingAServer
' No Connection initially
ConnectionEstablished = False
' Server listens , Client connects, both refreing to the same Port No.
If IamServer Then
myWinsock.LocalPort = myPortNo
myWinsock.Listen
Else
myWinsock.Connect TCPAddress, myPortNo
End If
' Schedule to reconnect
ReConnectTimer.Enabled = True
End Sub

<V>Cardkey 1234 Valid entry<E>Cardkey 4356 Exit<I>Cardkey 6423 Invalid Cardkey

Dim i, AMessage
Dim DString as clsString
Set DString = New clsString
' prefix the dummy character "*"
IncomingMessage = "*" & IncomingMessage
DString.Text = IncomingMessage
DString.Delmiter = "<"
' Ignore the first token which is the dummy character "*"
For i= 2 to DString.TokenCount
AMessage = "<" & DString.TokenAt(i)
Select Case Left(AMessage,3)
Case "<E>"
' Process Exit Cardkey
Case "<I>"
' Process Invalid Cardkey
Case "<V>"
' Process Valid Entry Cardkey
End Select
Next

Function SimilarWords(ByVal Word, ByVal ILen, ByVal TWord, ByVal Tlen) As Boolean
' Two words are considered Similar if the shorter word has at least (its length minus 2)
' characters that are found in the other word.
' In other words, the two words differ only a couple characters at the most.
Dim L1, L2, W1, W2
Dim i, MatchCount, Pos
' Identify the shorter Word and its length
If ILen > Tlen Then
L1 = ILen
L2 = Tlen
W1 = UCase(Word)
W2 = UCase(TWord)
Else
L1 = Tlen
L2 = ILen
W1 = UCase(TWord)
W2 = UCase(Word)
End If
MatchCount = 0
' Iterate through each character of the shorter word, i.e. W2
For i = 1 To L2
' Locate a character of W2 in W1
Pos = InStr(W1, Mid(W2, i, 1))
If Pos > 0 Then
' Increment the number of same characters
MatchCount = MatchCount + 1
' Temporary remove the matched character from W1
W1 = Left(W1, Pos - 1) & Mid(W1, Pos + 1)
End If
Next
If MatchCount >= (L2 - 2) Then
SimilarWords = True
Else
SimilarWords = False
End If
End Function

Function ToUTF8(ByVal UTF16 As Long) As Byte()
' Convert a 16bit UTF-16BE to 2 or 3 UTF-8 bytes
Dim bArray() As Byte
If UTF16 < &H80 Then
ReDim bArray(0) ' one byte UTF-8
bArray(0) = UTF16 ' Use number as is
ElseIf UTF16 < &H800 Then
ReDim bArray(1) ' two byte UTF-8
bArray(1) = &H80 + (UTF16 And &H3F) ' Least Significant 6 bits
UTF16 = UTF16 \ &H40 ' Shift UTF16 number right 6 bits
bArray(0) = &HC0 + (UTF16 And &H1F) ' Use 5 remaining bits
Else
ReDim bArray(2) ' three byte UTF-8
bArray(2) = &H80 + (UTF16 And &H3F) ' Least Significant 6 bits
UTF16 = UTF16 \ &H40 ' Shift UTF16 number right 6 bits
bArray(1) = &H80 + (UTF16 And &H3F) ' Use next 6 bits
UTF16 = UTF16 \ &H40 ' Shift UTF16 number right 6 bits again
bArray(0) = &HE0 + (UTF16 And &HF) ' Use 4 remaining bits
End If
ToUTF8 = bArray ' Return UTF-8 bytes in an array
End Function
Function ToUTF16(bArray) As Long
' Convert 2 or 3 UTF-8 bytes to a 16bit UTF-16BE
Dim IntUB
IntUB = UBound(bArray) ' Find out how many bytes UTF-8 takes
Select Case IntUB
Case 0 ' one byte UTF-8. Note that bArray starts with index=0
ToUTF16 = bArray(0) ' Use number as is
Case 1 ' two byte UTF-8
ToUTF16 = (bArray(0) And &H1F) * &H40 + (bArray(1) And &H3F)
Case 2 ' three byte UTF-8
ToUTF16 = (bArray(0) And &HF) * &H1000 + (bArray(1) And &H3F) * &H40 + (bArray(2) And &H3F)
End Select
End Function

Function UpperUniChar(Ch) As String
' Return the Uppercase for a given vowel or dd
Dim Pos ' Position of character in Unicode vowel list
' Locate the character in list of Unicode vowels
Pos = InStr(UVowels, Ch)
If (Pos > 67) Then
UpperUniChar = Ch ' It's already uppercase - leave it alone
ElseIf (Pos > 0) Then
' It's a Lowercase Unicode Vowel - so get the corresponding Uppercase vowel in the list
UpperUniChar = Mid(UVowels, Pos + 67, 1)
Else
' It's just a normal ANSI character
UpperUniChar = UCase(Ch)
End If
End Function

Function ToUniDecimal(UniString As String) As String
' Return the HTML equivalent string of a Unicode string
Dim i As Integer ' Must declare as integer for CopyMemory to work
Dim TLen, TStr
Dim b1 As Byte
Dim b2 As Byte
Dim UTF16 As Long
TLen = Len(UniString) ' Get Length of input Unicode string
If TLen = 0 Then Exit Function ' Get out if null string
' Iterate through each character in the string
For i = 1 To TLen
If IsUniChar(Mid(UniString, i, 1)) Then
' Cast the String character to 2 bytes
CopyMemory b1, ByVal StrPtr(UniString) + ((i - 1) * 2), 1
CopyMemory b2, ByVal StrPtr(UniString) + ((i - 1) * 2) + 1, 1
' Combine the 2 bytes into the Unicode UTF-16
UTF16 = b2 ' assign b2 to UTF16 before multiplying by 256 to avoid overflow
UTF16 = UTF16 * 256 + b1
' Convert UTF-16 to format ✏ for HTML
TStr = TStr & "&#" & Trim(CStr(UTF16)) & ";"
Else
' Get here if it;s an ANSI character
TStr = TStr & Mid(UniString, i, 1)
End If
Next
ToUniDecimal = TStr ' Return the HTML string
End Function

Public Function ReadTextFile(FileName) As String
' Write a Unicode String to UTF-16LE Text file
' Remember to Project | References "Microsoft Scripting Runtime" to support
' FileSystemObject & TextStream
Dim Fs As FileSystemObject
Dim TS As TextStream
' Create a FileSystem Object
Set Fs = CreateObject("Scripting.FileSystemObject")
' Open TextStream for Input.
' TriStateTrue means Read Unicode UTF-16LE
Set TS = Fs.OpenTextFile(FileName, ForReading, False, TristateTrue)
ReadTextFile = TS.ReadAll ' Read the whole content of the text file in one stroke
TS.Close ' Close the Text Stream
Set Fs = Nothing ' Dispose FileSystem Object
End Function
Public Sub WriteTextFile(FileName, StrOutText)
' Read a Unicode String from UTF-16LE Text file
' Remember to Project | References "Microsoft Scripting Runtime" to support
' FileSystemObject & TextStream
Dim Fs As FileSystemObject
Dim TS As TextStream
' Create a FileSystem Object
Set Fs = CreateObject("Scripting.FileSystemObject")
' Open TextStream for Output, create file if necesssary
' TriStateTrue means Write Unicode UTF-16LE
Set TS = Fs.OpenTextFile(FileName, ForWriting, True, TristateTrue)
TS.Write StrOutText ' Write the whole StrOutText string in one stroke
TS.Close ' Close the Text Stream
Set Fs = Nothing ' Dispose FileSystem Object
End Sub

Dim MyUnicodeText As clsUnicodeText
Set MyUnicodeText = New clsUnicodeText
' Read Unicode Text from file txtFileName and display in TextBox1
TextBox1.Text = MyUnicodeText.ReadUnicode(txtFileName)
Listing của Class clsUnicodeText như sau:
Option Explicit
Private mDOMTextFile As DOMDocument
Private mXMLPath As String
Public Function ReadUnicode(TXMLPath)
Dim objTextFileRoot As IXMLDOMElement
Set mDOMTextFile = New DOMDocument
mXMLPath = TXMLPath
mDOMTextFile.Load mXMLPath
'start at the root element of the XML
Set objTextFileRoot = mDOMTextFile.documentElement
ReadUnicode = objTextFileRoot.nodeTypedValue
End Function
Public Sub WriteUnicode(OutText, Optional TXMLPath)
Dim tDOMNode As IXMLDOMElement ' Temporary Node for DOM
If IsMissing(TXMLPath) Then
' Save the information on the screen by creating a new element and add its children to the DOM object
mDOMTextFile.documentElement.Text = OutText
' Update the XML file
mDOMTextFile.save mXMLPath
Else
Set mDOMTextFile = New DOMDocument
' Create a Node called "Text" in DOM
Set tDOMNode = mDOMTextFile.createElement("Text")
' Make it the Root Node
mDOMTextFile.appendChild tDOMNode
' Assign Output Text to Root Node
mDOMTextFile.documentElement.Text = OutText
' Update the XML file
mDOMTextFile.save TXMLPath
End If
End Sub

Function UTF8ToUniStr(BArray) As String
' Convert a byte stream of UTF-8 to Unicode String
Dim i As Long
Dim TopIndex As Long
Dim TwoBytes(1) As Byte
Dim ThreeBytes(2) As Byte
Dim AByte As Byte
Dim TStr As String
TopIndex = UBound(BArray) ' Number of bytes equal TopIndex+1
If TopIndex = 0 Then Exit Function ' get out if there's nothing to convert
i = 0 ' Initialise pointer
' Iterate through the Byte Array
Do While i <= TopIndex
AByte = BArray(i) ' fetch a byte
If AByte = &HE1 Then
' Start of 3 byte UTF-8 group for a character
' Copy 3 byte to ThreeBytes
ThreeBytes(0) = BArray(i): i = i + 1
ThreeBytes(1) = BArray(i): i = i + 1
ThreeBytes(2) = BArray(i): i = i + 1
' Convert Byte array to UTF-16 then Unicode
TStr = TStr & ChrW(ToUTF16(ThreeBytes))
ElseIf (AByte >= &HC3) And (AByte <= &HC6) Then
' Start of 2 byte UTF-8 group for a character
TwoBytes(0) = BArray(i): i = i + 1
TwoBytes(1) = BArray(i): i = i + 1
' Convert Byte array to UTF-16 then Unicode
TStr = TStr & ChrW(ToUTF16(TwoBytes))
Else
' Normal ANSI character - use it as is
TStr = TStr & Chr(AByte): i = i + 1 ' Increment byte array index
End If
Loop
UTF8ToUniStr = TStr ' Return the resultant string
End Function