分类：
2008-10-13 16:33:27
Option Explicit
Dim Test() As Integer
Const N = 10
Dim s(1 To N) As Integer
Dim I%
Dim Ml(0 To 11) As Integer '正常年份的每月天數據數組
Dim Y%, M%, D% 'y 年 m 月 d 日
Dim Outy%, Outm%, Outd% 'outy 輸出年;月;日
Dim Nm(0 To 50, 0 To 13) As String ' 兩位數組 一列 存取當前年份 二列存取(當年是月份yun,若是0沒有; 農曆每月初一所對應的陽歷日期)
Sub Init()
Dim Str As String
Str = 0 & "," & "0217" & "," & "0318" & "," & "0417" & "," & "0517" & "," & "0615" & "," & "0715" & "," & "0814" & "," & "0912" & "," & "1011" & "," & "1110" & "," & "1209" & "," & "1308"
Str = Str & "," & 0 & "," & "0206" & "," & "0308" & "," & "0406" & "," & "0506" & "," & "0605" & "," & "0704" & "," & "0803" & "," & "0901" & "," & "1001" & "," & "1030" & "," & "1129" & "," & "1228"
Str = Str & "," & 5 & "," & "0127" & "," & "0225" & "," & "0326" & "," & "0424" & "," & "0524" & "," & "0622" & "," & "0722" & "," & "0820" & "," & "0919" & "," & "1019" & "," & "1117" & "," & "1217" & "," & "1315"
Str = Str & "," & 0 & "," & "0214" & "," & "0315" & "," & "0414" & "," & "0513" & "," & "0611" & "," & "0711" & "," & "0810" & "," & "0908" & "," & "1008" & "," & "1107" & "," & "1206" & "," & "1305"
Str = Str & "," & 0 & "," & "0203" & "," & "0305" & "," & "0403" & "," & "0503" & "," & "0601" & "," & "0630" & "," & "0730" & "," & "0828" & "," & "0927" & "," & "1027" & "," & "1125" & "," & "1225"
Str = Str & "," & 3 & "," & "0124" & "," & "0222" & "," & "0324" & "," & "0422" & "," & "0522" & "," & "0620" & "," & "0719" & "," & "0818" & "," & "0916" & "," & "1016" & "," & "1114" & "," & "1214" & "," & "1313"
Str = Str & "," & 0 & "," & "0212" & "," & "0312" & "," & "0411" & "," & "0510" & "," & "0609" & "," & "0708" & "," & "0806" & "," & "0905" & "," & "1004" & "," & "1103" & "," & "1202" & "," & "1301"
Str = Str & "," & 8 & "," & "0131" & "," & "0302" & "," & "0331" & "," & "0430" & "," & "0529" & "," & "0628" & "," & "0727" & "," & "0825" & "," & "0924" & "," & "1023" & "," & "1122" & "," & "1221" & "," & "1320"
Str = Str & "," & 0 & "," & "0218" & "," & "0320" & "," & "0419" & "," & "0519" & "," & "0617" & "," & "0717" & "," & "0815" & "," & "0913" & "," & "1013" & "," & "1111" & "," & "1211" & "," & "1309"
Str = Str & "," & 0 & "," & "0208" & "," & "0309" & "," & "0408" & "," & "0508" & "," & "0606" & "," & "0706" & "," & "0804" & "," & "0903" & "," & "1002" & "," & "1101" & "," & "1130" & "," & "1230"
Str = Str & "," & 6 & "," & "0128" & "," & "0227" & "," & "0327" & "," & "0426" & "," & "0525" & "," & "0624" & "," & "0724" & "," & "0822" & "," & "0921" & "," & "1020" & "," & "1119" & "," & "1218" & "," & "1317"
Str = Str & "," & 0 & "," & "0215" & "," & "0317" & "," & "0415" & "," & "0515" & "," & "0613" & "," & "0713" & "," & "0811" & "," & "0910" & "," & "1010" & "," & "1108" & "," & "1208" & "," & "1306"
Str = Str & "," & 0 & "," & "0205" & "," & "0306" & "," & "0405" & "," & "0504" & "," & "0602" & "," & "0702" & "," & "0731" & "," & "0830" & "," & "0929" & "," & "1028" & "," & "1127" & "," & "1227"
Str = Str & "," & 4 & "," & "0125" & "," & "0224" & "," & "0325" & "," & "0424" & "," & "0523" & "," & "0621" & "," & "0721" & "," & "0819" & "," & "0918" & "," & "1017" & "," & "1116" & "," & "1216" & "," & "1315"
Str = Str & "," & 0 & "," & "0213" & "," & "0314" & "," & "0412" & "," & "0512" & "," & "0610" & "," & "0709" & "," & "0808" & "," & "0906" & "," & "1006" & "," & "1104" & "," & "1204" & "," & "1303"
Str = Str & "," & 0 & "," & "0202" & "," & "0303" & "," & "0402" & "," & "0501" & "," & "0531" & "," & "0629" & "," & "0728" & "," & "0827" & "," & "0925" & "," & "1024" & "," & "1123" & "," & "1223"
Str = Str & "," & 3 & "," & "0121" & "," & "0220" & "," & "0322" & "," & "0421" & "," & "0520" & "," & "0619" & "," & "0718" & "," & "0816" & "," & "0915" & "," & "1014" & "," & "1112" & "," & "1212" & "," & "1311"
Str = Str & "," & 0 & "," & "0209" & "," & "0311" & "," & "0410" & "," & "0509" & "," & "0608" & "," & "0708" & "," & "0806" & "," & "0904" & "," & "1004" & "," & "1102" & "," & "1202" & "," & "1231"
Str = Str & "," & 7 & "," & "0130" & "," & "0228" & "," & "0329" & "," & "0427" & "," & "0527" & "," & "0626" & "," & "0725" & "," & "0824" & "," & "0922" & "," & "1022" & "," & "1120" & "," & "1220" & "," & "1318"
Str = Str & "," & 0 & "," & "0217" & "," & "0318" & "," & "0417" & "," & "0516" & "," & "0615" & "," & "0714" & "," & "0813" & "," & "0912" & "," & "1011" & "," & "1110" & "," & "1209" & "," & "1308"
Str = Str & "," & 0 & "," & "0206" & "," & "0308" & "," & "0406" & "," & "0505" & "," & "0604" & "," & "0703" & "," & "0802" & "," & "0901" & "," & "0930" & "," & "1030" & "," & "1129" & "," & "1228"
Str = Str & "," & 5 & "," & "0127" & "," & "0225" & "," & "0327" & "," & "0425" & "," & "0524" & "," & "0623" & "," & "0722" & "," & "0821" & "," & "0919" & "," & "1019" & "," & "1118" & "," & "1218" & "," & "1316"
Str = Str & "," & 0 & "," & "0215" & "," & "0315" & "," & "0414" & "," & "0513" & "," & "0611" & "," & "0711" & "," & "0809" & "," & "0908" & "," & "1007" & "," & "1106" & "," & "1206" & "," & "1304"
Str = Str & "," & 0 & "," & "0203" & "," & "0305" & "," & "0403" & "," & "0503" & "," & "0601" & "," & "0630" & "," & "0730" & "," & "0828" & "," & "0926" & "," & "1026" & "," & "1125" & "," & "1224"
Str = Str & "," & 4 & "," & "0123" & "," & "0222" & "," & "0324" & "," & "0422" & "," & "0522" & "," & "0620" & "," & "0719" & "," & "0818" & "," & "0916" & "," & "1015" & "," & "1114" & "," & "1214" & "," & "1312"
Str = Str & "," & 0 & "," & "0211" & "," & "0313" & "," & "0412" & "," & "0511" & "," & "0610" & "," & "0709" & "," & "0807" & "," & "0906" & "," & "1005" & "," & "1103" & "," & "1203" & "," & "1301"
Str = Str & "," & 8 & "," & "0131" & "," & "0301" & "," & "0331" & "," & "0429" & "," & "0529" & "," & "0627" & "," & "0727" & "," & "0825" & "," & "0924" & "," & "1023" & "," & "1121" & "," & "1221" & "," & "1319"
Str = Str & "," & 0 & "," & "0218" & "," & "0320" & "," & "0418" & "," & "0518" & "," & "0617" & "," & "0716" & "," & "0815" & "," & "0913" & "," & "1013" & "," & "1111" & "," & "1211" & "," & "1309"
Str = Str & "," & 0 & "," & "0207" & "," & "0309" & "," & "0407" & "," & "0507" & "," & "0606" & "," & "0705" & "," & "0804" & "," & "0903" & "," & "1002" & "," & "1101" & "," & "1130" & "," & "1230"
Str = Str & "," & 6 & "," & "0128" & "," & "0227" & "," & "0328" & "," & "0426" & "," & "0526" & "," & "0624" & "," & "0724" & "," & "0823" & "," & "0921" & "," & "1021" & "," & "1120" & "," & "1219" & "," & "1318"
Str = Str & "," & 0 & "," & "0216" & "," & "0317" & "," & "0415" & "," & "0514" & "," & "0613" & "," & "0712" & "," & "0811" & "," & "0909" & "," & "1009" & "," & "1108" & "," & "1207" & "," & "1306"
Str = Str & "," & 0 & "," & "0205" & "," & "0306" & "," & "0405" & "," & "0504" & "," & "0602" & "," & "0702" & "," & "0731" & "," & "0829" & "," & "0928" & "," & "1028" & "," & "1126" & "," & "1226"
Str = Str & "," & 4 & "," & "0125" & "," & "0224" & "," & "0325" & "," & "0424" & "," & "0523" & "," & "0621" & "," & "0721" & "," & "0819" & "," & "0917" & "," & "1017" & "," & "1115" & "," & "1215" & "," & "1314"
Str = Str & "," & 0 & "," & "0213" & "," & "0315" & "," & "0413" & "," & "0513" & "," & "0611" & "," & "0710" & "," & "0809" & "," & "0907" & "," & "1006" & "," & "1105" & "," & "1204" & "," & "1303"
Str = Str & "," & 0 & "," & "0202" & "," & "0303" & "," & "0401" & "," & "0501" & "," & "0531" & "," & "0629" & "," & "0728" & "," & "0827" & "," & "0925" & "," & "1024" & "," & "1123" & "," & "1222"
Str = Str & "," & 2 & "," & "0121" & "," & "0220" & "," & "0321" & "," & "0420" & "," & "0520" & "," & "0618" & "," & "0718" & "," & "0816" & "," & "0915" & "," & "1014" & "," & "1112" & "," & "1212" & "," & "1310"
Str = Str & "," & 0 & "," & "0209" & "," & "0310" & "," & "0409" & "," & "0509" & "," & "0607" & "," & "0707" & "," & "0806" & "," & "0904" & "," & "1004" & "," & "1102" & "," & "1202" & "," & "1231"
Str = Str & "," & 6 & "," & "0129" & "," & "0228" & "," & "0329" & "," & "0428" & "," & "0527" & "," & "0626" & "," & "0726" & "," & "0824" & "," & "0923" & "," & "1023" & "," & "1121" & "," & "1221" & "," & "1319"
Str = Str & "," & 0 & "," & "0217" & "," & "0318" & "," & "0416" & "," & "0516" & "," & "0614" & "," & "0714" & "," & "0812" & "," & "0911" & "," & "1011" & "," & "1109" & "," & "1209" & "," & "1308"
Str = Str & "," & 0 & "," & "0206" & "," & "0308" & "," & "0406" & "," & "0505" & "," & "0604" & "," & "0703" & "," & "0802" & "," & "0831" & "," & "0930" & "," & "1029" & "," & "1128" & "," & "1228"
Str = Str & "," & 5 & "," & "0127" & "," & "0225" & "," & "0327" & "," & "0425" & "," & "0524" & "," & "0623" & "," & "0722" & "," & "0820" & "," & "0919" & "," & "1018" & "," & "1117" & "," & "1217" & "," & "1316"
Str = Str & "," & 0 & "," & "0215" & "," & "0316" & "," & "0415" & "," & "0514" & "," & "0612" & "," & "0712" & "," & "0810" & "," & "0908" & "," & "1008" & "," & "1106" & "," & "1206" & "," & "1305"
Str = Str & "," & 0 & "," & "0204" & "," & "0304" & "," & "0403" & "," & "0503" & "," & "0601" & "," & "0630" & "," & "0730" & "," & "0828" & "," & "0926" & "," & "1026" & "," & "1124" & "," & "1224"
Str = Str & "," & 3 & "," & "0123" & "," & "0221" & "," & "0323" & "," & "0422" & "," & "0521" & "," & "0620" & "," & "0719" & "," & "0818" & "," & "0916" & "," & "1015" & "," & "1114" & "," & "1213" & "," & "1312"
Str = Str & "," & 0 & "," & "0210" & "," & "0312" & "," & "0411" & "," & "0511" & "," & "0609" & "," & "0709" & "," & "0807" & "," & "0906" & "," & "1005" & "," & "1103" & "," & "1203" & "," & "1301"
Str = Str & "," & 8 & "," & "0131" & "," & "0301" & "," & "0331" & "," & "0430" & "," & "0529" & "," & "0628" & "," & "0727" & "," & "0826" & "," & "0925" & "," & "1024" & "," & "1122" & "," & "1222" & "," & "1320"
Str = Str & "," & 0 & "," & "0219" & "," & "0319" & "," & "0418" & "," & "0517" & "," & "0616" & "," & "0716" & "," & "0814" & "," & "0913" & "," & "1012" & "," & "1111" & "," & "1211" & "," & "1309"
Str = Str & "," & 0 & "," & "0207" & "," & "0309" & "," & "0407" & "," & "0507" & "," & "0605" & "," & "0705" & "," & "0803" & "," & "0902" & "," & "1002" & "," & "1031" & "," & "1130" & "," & "1230"
Str = Str & "," & 5 & "," & "0128" & "," & "0227" & "," & "0328" & "," & "0426" & "," & "0526" & "," & "0624" & "," & "0723" & "," & "0822" & "," & "0921" & "," & "1020" & "," & "1119" & "," & "1219" & "," & "1317"
Str = Str & "," & 0 & "," & "0216" & "," & "0318" & "," & "0416" & "," & "0515" & "," & "0614" & "," & "0713" & "," & "0811" & "," & "0910" & "," & "1009" & "," & "1108" & "," & "1208" & "," & "1307"
Str = Str & "," & 0 & "," & "0205" & "," & "0306" & "," & "0405" & "," & "0504" & "," & "0602" & "," & "0702" & "," & "0731" & "," & "0829" & "," & "0928" & "," & "1027" & "," & "1126" & "," & "1226"
'ml=new Array(31,28,31,30,31,30,31,31,30,31,30,31); //正常平年月份天數
Ml(0) = 31: Ml(1) = 28: Ml(2) = 31: Ml(3) = 30
Ml(4) = 31: Ml(5) = 30: Ml(6) = 31: Ml(7) = 31
Ml(8) = 30: Ml(9) = 31: Ml(10) = 30: Ml(11) = 31
Dim Test() As String
Dim J%, K%
Test = Split(Str, ",", -1, vbTextCompare)
J = 0
For I = 0 To UBound(Test)
Select Case J
Case 2, 5, 7, 10, 13, 16, 18, 21, 24, 26, 29, 32, 35, 37, 40, 43, 45, 48 '有14個
For K = 0 To 13
Nm(J, K) = Test(I + K)
Next K
I = I + 13
Case Else
For K = 0 To 12
Nm(J, K) = Test(I + K)
Next K
I = I + 12
End Select
J = J + 1
Next I
End Sub
Function Length(Y, M) As Integer '當前年月的天數
If ((M = 2) And ((Y + 50) Mod 4 = 0)) Then
Length = 29
Else
Length = Ml((M + 11) Mod 12)
End If
End Function
Function Ctog(objDate As Date) As Date '//轉公歷
Y = Year(objDate) - 1950
M = Month(objDate)
D = Day(objDate)
If Check1.Value = 1 And M <> Nm(Y, 0) Then
MsgBox "不存在日期"
End If
If (Check1.Value = 1 And M = Nm(Y, 0)) Or (CInt(Nm(Y, 0)) > 0 And M > CInt(Nm(Y, 0))) Then M = M + 1
Outm = CInt(Mid(Nm(Y, M), 1, 2))
Outd = CInt(Mid(Nm(Y, M), 3, 4)) + D - 1
If (Outd > Length(Y, Outm)) Then
Outd = Outd - Length(Y, Outm)
Outm = Outm + 1
End If
Outy = Y + 1950
If (Outm > 12) Then
Outm = Outm - 12
Outy = Outy + 1
End If
' Lab.Caption = "陽歷為: (公歷)" & outy & "年" & outm & "月" & outd & "日"
Ctog = DateSerial(Outy, Outm, Outd)
End Function
Function Gtoc(objDate As Date) As Date '////轉農歷
Dim Md$, K%
Dim Rn$ '字符串 存取是否yun
Y = Year(objDate) - 1950
M = Month(objDate)
D = Day(objDate)
If D > Length(Y, M) Then MsgBox "日期出錯"
Md = Format(D, "00")
Md = Format(M, "00") & Md
Select Case Y
Case 2, 5, 7, 10, 13, 16, 18, 21, 24, 26, 29, 32, 35, 37, 40, 43, 45, 48 '有14個
K = 13
Case Else
K = 12
End Select
For I = 0 To 12
If CInt(Nm(Y, I + 1)) > CInt(Md) Or I + 1 = K Then Exit For
Next I
If I = 0 Then
If Y = 0 Then
MsgBox "超出范"
Exit Function
End If
Y = Y - 1
I = K
Md = CInt(CInt(Md) + 1200)
If CInt(Nm(Y, I)) > CInt(Md) Then I = I - 1
End If
If Mid(Nm(Y, I), 1, 2) = Mid(Md, 1, 2) Then
Outd = CInt(Mid(Md, 3, 2)) - CInt(Mid(Nm(Y, I), 3, 2)) + 1
Else
Outd = Length(Y, Mid(Nm(Y, I), 1, 2)) + CInt(Mid(Md, 3, 2)) - CInt(Mid(Nm(Y, I), 3, 2)) + 1
End If
Outm = I
Rn = ""
If (Nm(Y, 0) <> 0) Then
If (Outm = Nm(Y, 0) + 1) Then Rn = "云月"
If (Outm > Nm(Y, 0)) Then Outm = Outm - 1
End If
Outy = Y + 1950
Gtoc = DateSerial(Outy, Outm, Outd)
End Function
Private Sub Command2_Click()
If DTPicker1.Year < 1952 Or DTPicker1.Year > 2000 Then
MsgBox "超出計算值"
Exit Sub
End If
Lab.Caption = "陰歷為: (農歷)" & Ctog(DTPicker1.Value)
End Sub
Private Sub Command3_Click()
If DTPicker1.Year < 1952 Or DTPicker1.Year > 2000 Then
MsgBox "超出計算值"
Exit Sub
End If
Lab.Caption = "陰歷為: (農歷)" & Gtoc(DTPicker2.Value)
End Sub
Private Sub Form_Load()
DTPicker1.Value = "1980/01/01"
DTPicker2.Value = "1980/01/01"
Init
End Sub
