Lưu trữ danh mục: Excel

Code tham khảo từ Hongocduc

Option Explicit
 Public Lday, Lmonth As Byte, Lyear As Integer, isLeap, LunarInfo
 ‘ chú thích
 Sub lunar(d, m, y)
 Dim DiffADate, Counter, i, Temp, Leap
     ‘ tính sô ngày tù môc 1/31/1900   ‘ghi chú: d se Ðuoc xem nhu month
     DiffADate = DateDiff(“d”, #1/31/1900#, CDate(m & “-” & d & “-” & y))
     Counter = -1 ‘ngày 31/1/1900 có DateDiff = 0 tuong úng ÂL là ngày 1
         ‘nên counter = -1 vì ngày ÂL = DateDiff – counter
     Lyear = 1900  ‘nam bat Ðâu tính, Lyear là nam ÂL tuong Ðuong DL
         For i = Lyear To 2199 ‘ Ðêm trong 300 nam kê tiêp
             Temp = YearDays(i) ‘goi Function YearDays nam Ðang Ðêm = sô ngày/nam
             Counter = Counter + Temp ‘cong sô ngày dôn
If Counter >= DiffADate Then                  ‘nêu sô ngày dôn >= DiffADate
                     Counter = Counter – Temp ‘ tru` sô ngày dôn 1 nam Ðang tính
                     Exit For  ‘và thoát vòng lap, = Ðã có giá tri Lyear
End If
             Lyear = Lyear + 1 ‘nam Ðang Ðêm thêm 1 don vi
         Next
  ‘so’ di phai tính nhu thê Ðê tìm chính xác nhung ngày cuôi nam ÂL mà Ðã sang nam mo’i DL
  ‘trong truong hop nây, xem nhu vân nam cu
 Leap = LeapMonth(Lyear) ‘ goi hàm LeapMonth, tháng nhuân là tháng mây?
 isLeap = “” ‘ set giá tri xác Ðinh cua tháng nhuân = “”
 Lmonth = 1

 For i = 1 To 12
If Leap > 0 And i = Leap + 1 And isLeap = “” Then
 isLeap = “(N)” ‘nêu tháng nhuân có và I lo’n hon 1 thì Nhuân
 Lmonth = Lmonth – 1 ‘tháng lùi 1
 i = i – 1 ‘Ðêm lùi 1
 Temp = LeapDay(Lyear) ‘ goi hàm leapday, tính sô ngày nhuân
Else
 Temp = MonthDays(Lyear, i) ‘goi hàm monthdays tính sô ngày thuong
End If

 If isLeap = “(N)” And i <> Leap Then isLeap = “”
  ‘ Nêu xác dinh Nhuân và I khác tháng nhuân thì Xác Ðinh không phai Nhuan
 Counter = Counter + Temp ‘ cong dôn ngày tù vi trí Exit For khi xác Ðinh Lyear

If Counter >= DiffADate Then  ‘nêu sô ngày dôn >= DiffADate
 Counter = Counter – Temp ‘ tru` sô ngày dôn 1 tháng Ðang tính
 Exit For   ‘và thoát vòng lap, = Ðã có giá tri Lmonth
End If
 Lmonth = Lmonth + 1 ‘tháng Ðang Ðêm thêm 1 don vi
 Next
 Lday = DiffADate – Counter ‘Ngày Ðuoc xác Ðinh
 End Sub
 Function LeapMonth(y) ””””””
 If y >= 1900 Then LeapMonth = LunarInfo(y – 1900) And &HF Else LeapMonth = 0
 ‘Tháng nhuân = LunarInfo(nam Ðang chuyên) And &HF = ( tu 0 – 12) ngoài ra thì = 0
 End Function

 Function LeapDay(y) ”””””
If LunarInfo(y – 1900) And &HF Then  ‘nêu có tháng nhuân thì
 If LunarInfo(y – 1900) And &H10000 Then LeapDay = 30 Else LeapDay = 29
 ‘ Nêu LunarInfo(nam Ðang chuyên) And &H10000 > 0 thì 30 không thì 29 ngày
Else
 LeapDay = 0
End If
 End Function

 Function MonthDays(y, m) ”””””””’
 Dim MonthMask
 MonthMask = Array(32768, 16384, 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16)
 ‘ Mang loc tháng(1-12) = MonthMask(0-11)
 ‘ Nêu LunarInfo(nam Ðang chuyên) And Mang loc tháng(tháng Ðang chuyên) > 0 thì 30 ngoài ra thì 29
 If LunarInfo(y – 1900) And MonthMask(m – 1) Then MonthDays = 30 Else MonthDays = 29
 End Function

 Function YearDays(y) ””””””’
 Dim i, MonthMask
 MonthMask = Array(32768, 16384, 8192, 4096, 2048, 1024, 512, 256, 128, 64, 32, 16)
 YearDays = 348  ’12 tháng x 29 ngày
 For i = 0 To 11 ‘tháng nào có 30 ngày thì thêm 1
 If LunarInfo(y – 1900) And MonthMask(i) Then YearDays = YearDays + 1
 Next
 YearDays = YearDays + LeapDay(y) ‘ cong thêm sô ngày nhuân nêu có
 End Function
 ‘Ham so chuyen doi tu Duong lich sang Am lich dang ngay,thang,nam
 Public Function TransLu(d, m, y)
 Call Goi
 ‘ cau trúc cua hàm lunar là (d, m, y), VB6 dùng (m, d, y) nên function TransLu
 ‘ se doi vi tri câu trúc khi goi hàm lunar
 Call lunar(m, d, y)
 TransLu = Lday & “/” & Lmonth & isLeap & “/” & Lyear
 End Function
 ‘Ham so chuyen doi tu Duong lich sang Am lich dang tu mot o
 Public Function TransLu1(NT As Date) ‘ NT = ngày tháng
 Call lunar(Day(NT), Month(NT), Year(NT)) ‘goi hàm Lunar theo câu trúc nây ?
 ‘ Ðê nghi nhu’ hàm TransLu làm: Call lunar(Month(NT), Day(NT), Year(NT))
 ‘TransLu1 = Lday & “-” & Lmonth & isLeap & “-” & CanchiV(Lyear – 0)
                                 ‘Hàm CanchiV bi thiêu!
 End Function

 Public Function TransSolar(d, m, y) As Date ‘Ngay thang nam am lich sang duong lich
 Dim iSd As Date
 iSd = DateSerial(y, m, d) – 70
 Do
 iSd = iSd + 1
 Loop Until TransLu(Day(iSd), Month(iSd), Year(iSd)) = d & “/” & m & “/” & y
 TransSolar = iSd
 End Function

 ‘Cach su dung:
 Private Sub Command1_Click()
     If Days = “” Or Months = “” Or Years = “” Then Exit Sub
     NgayAL = TransLu(Days, Months, Years)
 End Sub

 Private Sub Command2_Click()
 If Years = “” Then Exit Sub
 ThangNhuan = LeapMonth(Years)
 End Sub

 Private Sub Command3_Click()
 If Years = “” Then Exit Sub
 SoNgayNhuan = LeapDay(Years)
 End Sub

 Private Sub Command4_Click()
 If Years = “” Or Months = “” Then Exit Sub
 SoNgayThangT = MonthDays(Years, Months)
 End Sub

 Private Sub Command5_Click()
 If Years = “” Then Exit Sub
 SoNgayNam = YearDays(Years)
 End Sub

 Sub Goi()
 ‘Mang do HoNgocDuc tu xây dung, chu’a thông tin nam ÂL tu 1900-2199
 ‘nam Ðó tháng mây nhuân? gôm mây ngày? Môi tháng còn lai có mây ngày? nam Ðó có mây ngày?
 LunarInfo = Array( _
 &H3C4BD8, &H624AE0, &H4CA570, &H3854D5, &H5CD260, &H44D950, &H315554, &H5656A0, &H409AD0, &H2A55D2, &H504AE0, &H3AA5B6, &H60A4D0, &H48D250, &H33D255, &H58B540, &H42D6A0, &H2CADA2, &H5295B0, &H3F4977, _
 &H644970, &H4CA4B0, &H36B4B5, &H5C6A50, &H466D40, &H2FAB54, &H562B60, &H409570, &H2C52F2, &H504970, &H3A6566, &H5ED4A0, &H48EA50, &H336A95, &H585AD0, &H442B60, &H2F86E3, &H5292E0, &H3DC8D7, &H62C950, _
 &H4CD4A0, &H35D8A6, &H5AB550, &H4656A0, &H31A5B4, &H5625D0, &H4092D0, &H2AD2B2, &H50A950, &H38B557, &H5E6CA0, &H48B550, &H355355, &H584DA0, &H42A5B0, &H2F4573, &H5452B0, &H3CA9A8, &H60E950, &H4C6AA0, _
 &H36AEA6, &H5AAB50, &H464B60, &H30AAE4, &H56A570, &H405260, &H28F263, &H4ED940, &H38DB47, &H5CD6A0, &H4896D0, &H344DD5, &H5A4AD0, &H42A4D0, &H2CD4B4, &H52B250, &H3CD558, &H60B540, &H4AB5A0, &H3755A6, _
 &H5C95B0, &H4649B0, &H30A974, &H56A4B0, &H40AA50, &H29AA52, &H4E6D20, &H39AD47, &H5EAB60, &H489370, &H344AF5, &H5A4970, &H4464B0, &H2C74A3, &H50EA50, &H3D6A58, &H6256A0, &H4AAAD0, &H3696D5, &H5C92E0, _
 &H46C960, &H2ED954, &H54D4A0, &H3EDA50, &H2A7552, &H4E56A0, &H38A7A7, &H5EA5D0, &H4A92B0, &H32AAB5, &H58A950, &H42B4A0, &H2CBAA4, &H50AD50, &H3C55D9, &H624BA0, &H4CA5B0, &H375176, &H5C5270, &H466930, _
 &H307934, &H546AA0, &H3EAD50, &H2A5B52, &H504B60, &H38A6E6, &H5EA4E0, &H48D260, &H32EA65, &H56D520, &H40DAA0, &H2D56A3, &H5256D0, &H3C4AFB, &H6249D0, &H4CA4D0, &H37D0B6, &H5AB250, &H44B520, &H2EDD25, _
 &H54B5A0, &H3E55D0, &H2A55B2, &H5049B0, &H3AA577, &H5EA4B0, &H48AA50, &H33B255, &H586D20, &H40AD60, &H2D4B63, &H525370, &H3E49E8, &H60C970, &H4C54B0, &H3768A6, &H5ADA50, &H445AA0, &H2FA6A4, &H54AAD0, _
 &H4052E0, &H28D2E3, &H4EC950, &H38D557, &H5ED4A0, &H46D950, &H325D55, &H5856A0, &H42A6D0, &H2C55D4, &H5252B0, &H3CA9B8, &H62A930, &H4AB490, &H34B6A6, &H5AAD50, &H4655A0, &H2EAB64, &H54A570, &H4052B0, _
 &H2AB173, &H4E6930, &H386B37, &H5E6AA0, &H48AD50, &H332AD5, &H582B60, &H42A570, &H2E52E4, &H50D160, &H3AE958, &H60D520, &H4ADA90, &H355AA6, &H5A56D0, &H462AE0, &H30A9D4, &H54A2D0, &H3ED150, &H28E952, _
 &H4EB520, &H38D727, &H5EADA0, &H4A55B0, &H362DB5, &H5A45B0, &H44A2B0, &H2EB2B4, &H54A950, &H3CB559, &H626B20, &H4CAD50, &H385766, &H5C5370, &H484570, &H326574, &H5852B0, &H406950, &H2A7953, &H505AA0, _
 &H3BAAA7, &H5EA6D0, &H4A4AE0, &H35A2E5, &H5AA550, &H42D2A0, &H2DE2A4, &H52D550, &H3E5ABB, &H6256A0, &H4C96D0, &H3949B6, &H5E4AB0, &H46A8D0, &H30D4B5, &H56B290, &H40B550, &H2A6D52, &H504DA0, &H3B9567, _
 &H609570, &H4A49B0, &H34A975, &H5A64B0, &H446A90, &H2CBA94, &H526B50, &H3E2B60, &H28AB61, &H4C9570, &H384AE6, &H5CD160, &H46E4A0, &H2EED25, &H54DA90, &H405B50, &H2C36D3, &H502AE0, &H3A93D7, &H6092D0, _
 &H4AC950, &H32D556, &H58B4A0, &H42B690, &H2E5D94, &H5255B0, &H3E25FA, &H6425B0, &H4E92B0, &H36AAB6, &H5C6950, &H4674A0, &H31B2A5, &H54AD50, &H4055A0, &H2AAB73, &H522570, &H3A5377, &H6052B0, &H4A6950, _
 &H346D56, &H585AA0, &H42AB50, &H2E56D4, &H544AE0, &H3CA570, &H2864D2, &H4CD260, &H36EAA6, &H5AD550, &H465AA0, &H30ADA5, &H5695D0, &H404AD0, &H2AA9B3, &H50A4D0, &H3AD2B7, &H5EB250, &H48B540, &H33D556) ” /* Years 2100-2199 */
 End Sub

Public Function docso(chuyenso) As String
s09 = Array("", " M" & ChrW(7897) & "t", " hai", " ba", " b" & ChrW(7889) & "n", " n" & ChrW(259) & "m", " s" & ChrW(225) & "u", " b" & ChrW(7843) & "y", " t" & ChrW(225) & "m", " ch" & ChrW(237) & "n")
lop3 = Array("", " tri" & ChrW(7879) & "u", " ngh" & ChrW(236) & "n", " t" & ChrW(7927))
'Stop
If Trim(chuyenso) = "" Then
  DocSoUni = ""
ElseIf IsNumeric(chuyenso) = True Then
  If chuyenso < 0 Then dau = ChrW(226) & "m " Else dau = ""
  chuyenso = Application.WorksheetFunction.Round(Abs(chuyenso), 0)
  chuyenso = " " & chuyenso
  chuyenso = Replace(chuyenso, ",", "", 1)
  vt = InStr(1, chuyenso, "E")
  If vt > 0 Then
    sonhan = Val(Mid(chuyenso, vt + 1))
    chuyenso = Trim(Mid(chuyenso, 2, vt - 2))
    chuyenso = chuyenso & String(sonhan - Len(chuyenso) + 1, "0")
  End If
  chuyenso = Trim(chuyenso)
  sochuso = Len(chuyenso) Mod 9
  If sochuso > 0 Then chuyenso = String(9 - (sochuso Mod 12), "0") & chuyenso
  docso = ""
  i = 1
  lop = 1
  Do
    n1 = Mid(chuyenso, i, 1)
    n2 = Mid(chuyenso, i + 1, 1)
    n3 = Mid(chuyenso, i + 2, 1)
    baso = Mid(chuyenso, i, 3)
    i = i + 3
    If n1 & n2 & n3 = "000" Then
      If docso <> "" And lop = 3 And Len(chuyenso) - i > 2 Then s123 = " t" & ChrW(7927) Else s123 = ""
    Else
      If n1 = 0 Then
        If docso = "" Then s1 = "" Else s1 = " kh" & ChrW(244) & "ng tr" & ChrW(259) & "m"
      Else
        s1 = s09(n1) & " tr" & ChrW(259) & "m"
      End If
      If n2 = 0 Then
        If s1 = "" Or n3 = 0 Then
          s2 = ""
        Else
          s2 = " linh"
        End If
      Else
        If n2 = 1 Then s2 = " M" & ChrW(432) & ChrW(7901) & "i" Else s2 = s09(n2) & " m" & ChrW(432) & ChrW(417) & "i"
      End If
      If n3 = 1 Then
        If n2 = 1 Or n2 = 0 Then s3 = " M" & ChrW(7897) & "t" Else s3 = " m" & ChrW(7889) & "t"
      ElseIf n3 = 5 And n2 <> 0 Then
        s3 = " l" & ChrW(259) & "m"
      Else
        s3 = s09(n3)
      End If
      If i > Len(chuyenso) Then
        s123 = s1 & s2 & s3
      Else
        s123 = s1 & s2 & s3 & lop3(lop)
      End If
    End If
    lop = lop + 1
    If lop > 3 Then lop = 1
    docso = docso & s123
    If i > Len(chuyenso) Then Exit Do
  Loop
  If docso = "" Then docso = "kh" & ChrW(244) & "ng" Else docso = dau & Trim(docso)
Else
  docso = chuyenso
End If
End Function

--------------------

Function viethoa(ByVal strContent As String) As String
    Dim m As Object
    strContent = LCase(strContent)
    strContent = Application.Replace(strContent, 1, 1, UCase(Left$(strContent, 1)))
    With CreateObject("VBScript.RegExp")
        .Pattern = ".s."
        .Global = True
        For Each m In .Execute(strContent)
            strContent = Application.Replace(strContent, m.FirstIndex + 1, m.Length, UCase(m.Value))
        Next
    End With
    viethoa = strContent
End Function