lehongduc > 15-07-17, 08:13 AM
Function TachTen(HoVaTen As String) As String
Dim Ten As String
Dim i As Integer
Dim nTu As Integer
Dim St As String
Dim LngSt As Integer
HoVaTen = Trim(HoVaTen)
LngSt = Len(HoVaTen)
'Đoạn mã sau đây để xác định vị trí của ký tự trắng ngăn cách các từ trong chuỗi Họ và Tên, tính từ bên phải sang trái
'Bởi mục đích là ta tách phần Tên ra khỏi chuỗi Họ và Tên
i = InStrRev(HoVaTen, " ")
'Nếu chuỗi Họ và Tên chỉ có 1 từ (không có ký tự trắng ngăn cách nào)
If i = 0 Then
'Thì lấy nguyên từ duy nhất đó
Ten = HoVaTen
Else
Ten = Right(HoVaTen, LngSt - i)
End If
TachTen = Ten
End Functionlehongduc > 15-07-17, 08:43 AM
Function DaoChuoi(ChuoiDuaVao As String) As String
Dim LngSt As Integer, i As Integer
Dim ChuoiDao As String, ChuoiCon As String
ChuoiDuaVao = Trim(ChuoiDuaVao)
LngSt = Len(ChuoiDuaVao)
'Thực hiện vòng lặp Do để đảo chuỗi
Do
'Để lấy ra từng từ
' Các Bạn chú ý là ta phải lấy ra từng từ chứ không phải từng ký tự
' Ta biết rằng mỗi từ trong chuỗi đợc ngăn cách bằng 1 ký tự trắng.
' Do vậy để lấy ra từng từ ta chỉ cần xác định vị trí của ký tự trắng ấy là biết chiều dài của từ cần lấy ra
' Dòng lệnh dưới đây để xác định vị trí của ký tự trắng đó.
i = InStr(1, ChuoiDuaVao, " ")
'Biến ChuoiDuaVao là chỉ chuỗi đã được cắt bỏ từ đã đơợc tách sau mỗi lần lặp
'Nếu không còn ký tự trắng nào nữa, hoặc không có ký tự trắng nào trong chuỗi (chuỗi chỉ có 1 từ)
If i = 0 Then
ChuoiDao = ChuoiDuaVao & " " & ChuoiDao
Exit Do
Else
'Tách lấy từ là ChuoiCon với chiều dài của từ là vị trí i -1
ChuoiCon = Left(ChuoiDuaVao, i - 1)
End If
'Dòng lệnh sau để:
'Nối chuỗi con (ChuoiCon) vừa tách được ở trên vào đầu chuỗi đã được đảo ngược (ChuoiDao)
'Chú ý: Không nối chuỗi con vào cuối ChuoiDao
ChuoiDao = ChuoiCon & " " & ChuoiDao
'Dòng lệnh sau để xác định chuỗi còn lại (ChuoiDuaVao) sau khi đã tách từ ở bên trái ra
ChuoiDuaVao = right(ChuoiDuaVao, Len(ChuoiDuaVao) - Len(ChuoiCon) - 1)
Loop
DaoChuoi = ChuoiDao
End Functionlehongduc > 15-07-17, 08:52 AM
Function FindInArray(pList, pValue)
'Xac dinh vi tri cua gia tri pValue trong Array List pList
Dim i As Integer
Dim FoundValueLocation As Integer 'Vi tri cua pValue trong pList
FoundValueLocation = -1
'Vị trí của các thành phần trong 1 Array được xác định bắt đầu từ 0
' UBound là hàm xác định vị trí của thành phần cuối cùng của 1 Array
For i = 0 To UBound(pList)
If pList(i) = pValue Then
FoundValueLocation = i
Exit For
End If
Next i
FindInArray = FoundValueLocation
End Functionlehongduc > 15-07-17, 09:15 AM
Function mh(UnicodeText)
Dim LngSt As Integer
Dim i As Integer
Dim UniStr As String, MhStr As String
Dim UniArr, MhArr
Dim SubStr As String, k As Integer
Dim ReStr As String
'Tac dung: Ma hoa chuoi Unicode (UnicodeText)
'Lập chuỗi các ký tự mang dấu tiếng Việt Unicode gán cho biến UniStr
UniStr = "," & ChrW(97) & "," & ChrW(224) & "," & ChrW(225) & "," & ChrW(7843) & "," & ChrW(227) & "," & ChrW(7841)
UniStr = UniStr & "," & ChrW(259) & "," & ChrW(7857) & "," & ChrW(7855) & "," & ChrW(7859) & "," & ChrW(7861) & "," & ChrW(7863)
UniStr = UniStr & "," & ChrW(226) & "," & ChrW(7847) & "," & ChrW(7845) & "," & ChrW(7849) & "," & ChrW(7851) & "," & ChrW(7853)
UniStr = UniStr & "," & ChrW(101) & "," & ChrW(232) & "," & ChrW(233) & "," & ChrW(7867) & "," & ChrW(7869) & "," & ChrW(7865)
UniStr = UniStr & "," & ChrW(234) & "," & ChrW(7873) & "," & ChrW(7871) & "," & ChrW(7875) & "," & ChrW(7877) & "," & ChrW(7879)
UniStr = UniStr & "," & ChrW(105) & "," & ChrW(236) & "," & ChrW(237) & "," & ChrW(7881) & "," & ChrW(297) & "," & ChrW(7883)
UniStr = UniStr & "," & ChrW(117) & "," & ChrW(249) & "," & ChrW(250) & "," & ChrW(7911) & "," & ChrW(361) & "," & ChrW(7909)
UniStr = UniStr & "," & ChrW(432) & "," & ChrW(7915) & "," & ChrW(7913) & "," & ChrW(7917) & "," & ChrW(7919) & "," & ChrW(7921)
UniStr = UniStr & "," & ChrW(111) & "," & ChrW(242) & "," & ChrW(243) & "," & ChrW(7887) & "," & ChrW(245) & "," & ChrW(7885)
UniStr = UniStr & "," & ChrW(244) & "," & ChrW(7891) & "," & ChrW(7889) & "," & ChrW(7893) & "," & ChrW(7895) & "," & ChrW(7897)
UniStr = UniStr & "," & ChrW(417) & "," & ChrW(7901) & "," & ChrW(7899) & "," & ChrW(7903) & "," & ChrW(7905) & "," & ChrW(7907)
UniStr = UniStr & "," & ChrW(100) & "," & ChrW(273)
UniStr = UniStr & "," & ChrW(121) & "," & ChrW(7923) & "," & ChrW(253) & "," & ChrW(7927) & "," & ChrW(7929) & "," & ChrW(7925)
'Lập chuỗi mã hóa gán cho biến MhStr (mã hóa các ký tự mang dấu tiếng Việt Unicode)
MhStr = ",a00,a01,a02,a03,a04,a05" 'a
MhStr = MhStr & ",a10,a11,a12,a13,a14,a15" 'aw
MhStr = MhStr & ",a20,a21,a22,a23,a24,a25" 'â
MhStr = MhStr & ",e00,e01,e02,e03,e04,e05" 'e
MhStr = MhStr & ",e10,e11,e12,e13,e14,e15" 'ê
MhStr = MhStr & ",i00,i01,i02,i03,i04,i05" 'i
MhStr = MhStr & ",u00,u01,u02,u03,u04,u05" 'u
MhStr = MhStr & ",u10,u11,u12,u13,u14,u15" 'uw
MhStr = MhStr & ",o00,o01,o02,o03,o04,o05" 'o
MhStr = MhStr & ",o10,o11,o12,o13,o14,o15" 'ô
MhStr = MhStr & ",o20,o21,o22,o23,o24,o25" 'ow
MhStr = MhStr & ",d0,d1" 'dd
MhStr = MhStr & ",y00,y01,y02,y03,y04,y05" 'y
'Sử dụng Function Split (đây là Func của bản thân VBA)
'Để chuyển các chuỗi UniStr và MhStr sang Array:
'+ UniArr: là danh sách các ký tự Unicode tiếng Việt
'+ MhArr: là danh sách chuỗi mã hóa tương ứng
'Nhằm mục đích dễ xác định chuỗi mã hóa tương ứng
UniArr = Split(UniStr, ",")
MhArr = Split(MhStr, ",")
'Cắt các khoảng trống ở 2 đầu của Chuỗi Unicode đưa vào
UnicodeText = Trim(UnicodeText)
'Chuyển toàn bộ chuỗi Unicode sang chữ thường bằng function LCase của VBA
UnicodeText = LCase(UnicodeText)
'
LngSt = Len(UnicodeText)
'Duyệt từ đầu chuỗi đến cuối chuỗi Unicode đưa vào
'Lấy từng ký tự ra để kiểm tra xem
'có nằm trong danh sách các ký tự Unicode tiếng Việt hay không (Array UniArr)
'Nếu có, nghĩa là ký tự đó là ký tự Unicode tiếng Việt
'Ta sẽ xác định vị trí ký tự này trong danh sách Unicode tiếng Việt (Array UniArr)
'Từ đó lấy ra chuỗi mã hóa ở vị trí tương ứng trong danh sách mã hóa (Array MhArr)
For i = 1 To LngSt
SubStr = Mid(UnicodeText, i, 1) 'Tách từng ký tự ra
'Xác định vị trí của ký tự vừa tách ra bằng Func FindInArray ta đã viết ở trên
'Xem có hay không có trong danh sách ký tự Unicode tiếng Việt
k = FindInArray(UniArr, SubStr)
'Nếu có
If k > 0 Then
SubStr = MhArr(k) 'Nếu có trong UniArr thì lấy chuỗi mã hóa tương ứng trong danh sách ký tự mã hóa MhArr
End If
ReStr = ReStr & SubStr 'Nối chuỗi tìm được vào chuỗi mã hóa
Next i
mh = ReStr
End Function