'//接上
m11 = Array( _
    1.6768, -0.0431256817, 628.3019552485, -0.0000026638815, 6.1639211E-10, -5.4439728E-11, 0.51642, 11.2260974062, 6585.7609102104, -0.00021583699, -0.00000018708058, 9.3204945E-10, 0.41383, 13.5816519784, 14914.4523349355, -0.00006352424, 0.000000063330532, -2.5428962E-10, 0.37115, 5.5402729076, 7700.3894694766, 0.00015497663, 0.00000024979472, -1.1318993E-09, _
    0.2756, 2.3124288905, 8956.9933799736, 0.00014964887, 0.00000025102751, -1.2407788E-09, 0.2459863, -25.6198212459, -2.3011998397, 0.00015231275, 0.00000025041111, -1.1863391E-09, 0.07118, 7.9982533891, 7842.3648207073, -0.00022116475, -0.0000001858478, 0.00000000082317, 0.06128, 10.3538079614, 16171.0562454324, -0.000068852003, 0.000000064563317, -3.6316908E-10)
m12 = Array(0.00487, -0.0431256817, 628.3019552485, -0.0000026638815, 6.1639211E-10, -5.4439728E-11, 0.00228, -27.1705318325, -2.3011998397, 0.00015231275, 0.00000025041111, -1.1863391E-09, 0.0015, 11.2260974062, 6585.7609102104, -0.00021583699, -0.00000018708058, 9.3204945E-10)
m20 = Array( _
18461.24006, 1.6279052448, 8433.4661576405, -0.000064021295, -4.9499477E-09, 2.0216731E-11, 1010.1671484, 3.983459817, 16762.1575823656, 0.000088291456, 0.00000024546117, -1.1661223E-09, 999.6936555, 0.7276493275, -104.7747329154, 0.00021633405, 0.00000025536106, -1.2065558E-09, 623.6524746, 8.7690283983, 7109.2881325435, -0.0000021668263, 0.000000068896872, -3.2894608E-10, _
  199.4837596, 9.6692843156, 15647.5290230993, -0.00028252217, -0.00000019141414, 8.9782646E-10, 166.5741153, 6.4134738261, -1219.4032921817, -0.00015447958, -0.00000018151424, 0.000000000857393, 117.2606951, 12.0248388879, 23976.2204478244, -0.00013020942, 0.000000058996977, -2.8851262E-10, 61.9119504, 6.3390143893, 25090.8490070907, 0.00024060421, 0.00000049587228, -2.3524614E-09, _
    33.3572027, 11.1245829706, 15437.9795572686, 0.00015014592, 0.00000031930799, -1.5152852E-09, 31.7596709, 3.0832038997, 8223.9166918098, 0.0003686468, 0.00000050577218, -2.3928949E-09, 29.5766003, 8.8121540801, 6480.986177295, 0.00000049705523, 0.00000006828048, -2.7450635E-10, 15.5662654, 4.0579192538, -9548.0947169068, -0.00030679233, -0.00000043192536, 2.0437321E-09, _
    15.1215543, 14.3803934601, 32304.9118725496, 0.000022103334, 0.00000030940809, -1.4748517E-09, -12.0941511, 8.7259027166, 7737.590087792, -0.0000048307078, 0.000000069513264, -3.8338581E-10, 8.8681426, 9.7124099974, 15019.2270678508, -0.00027985829, -0.00000019203053, 9.5226618E-10, 8.04504, 0.6687636586, 8399.709110503, -0.000033191993, 0.000000032017096, -1.5363746E-10, _
    7.9585542, 12.0679645696, 23347.918492576, -0.00012754553, 0.000000058380585, -2.3407289E-10, 7.434555, 6.4565995078, -1847.7052474301, -0.0001518157, -0.00000018213063, 9.1183272E-10, -6.7314363, -4.0265854988, -16133.8556271171, -0.000090955337, -0.00000024484477, 1.1116826E-09, 6.579575, 16.8104074692, 14323.3509980023, -0.0002206677, -0.00000011756732, 5.4866364E-10, _
    -6.4600721, 1.584779563, 9061.768112889, -0.000066685176, -4.3335556E-09, -3.4222998E-11, -6.2964773, 4.8837157343, 25300.3984729215, -0.00019206388, -0.000000014849843, 6.0650192E-11, -5.6323538, -0.7707750092, 733.0766881638, -0.00021899793, -0.00000025474467, 1.1521161E-09, -5.3683961, 6.8263720663, 16204.8433027325, -0.000097115356, 0.000000027023515, -1.3414795E-10, _
    -5.3112784, 3.9403341353, 17390.4595376141, 0.000085627574, 0.00000024607756, -1.2205621E-09, -5.0759179, 0.6845236457, 523.5272223331, 0.00021367016, 0.00000025597745, -1.2609955E-09, -4.8396143, -1.6710309265, -7805.164202392, 0.000061357413, 5.5663398E-09, -7.4656459E-11, -4.8057401, 3.5705615768, -662.0890125485, 0.000030927234, 0.00000003692341, -1.7458141E-10, _
    3.9840545, 8.6945689615, 33419.5404318159, 0.00039291696, 0.0000007462834, -3.5388005E-09, 3.6744619, 19.1659620415, 22652.0424227274, -0.000068354947, 0.0000001328438, -6.3767543E-10, 2.9984815, 20.0662179587, 31190.2833132833, -0.00034871029, -0.00000012746721, 5.890971E-10, 2.7986413, -2.528161162, -16971.7070481963, 0.00034437664, 0.00000026526096, -1.2469893E-09, _
    2.4138774, 17.7106633865, 22861.5918885581, -0.00050102304, -0.00000037787833, 1.7754362E-09, 2.1863132, 5.5132179088, -9757.6441827375, 0.00012587576, 0.000000078796768, -3.6937954E-10, 2.1461692, 13.4801375428, 23766.6709819937, 0.00030245868, 0.0000005697191, -2.7016242E-09, 1.7659832, 11.1677086523, 14809.6776020201, 0.00015280981, 0.00000031869159, -1.4608454E-09, _
    -1.6244212, 7.3137297434, 7318.8375983742, -0.00043483492, -0.00000044182525, 2.0841655E-09, 1.5813036, 5.438758472, 16552.6081165349, 0.00052095955, 0.00000075618329, -0.000000003579234, 1.5197528, 16.7359480324, 40633.6032972747, 0.00017441609, 0.00000055981921, -2.6611908E-09, 1.5156341, 1.7023646816, -17876.7861416319, -0.00045910508, -0.00000068233647, 3.2300712E-09, _
    1.5102092, 5.497729645, 8399.6847301375, -0.000033094061, 0.000000031973462, -1.5436468E-10, -1.3178223, 9.6261586339, 16275.8309783478, -0.00028518605, -0.00000019079775, 8.4338673E-10, -1.2642739, 11.9817132061, 24604.5224030729, -0.0001328733, 0.000000059613369, -3.4295235E-10, 1.1918723, 22.421772531, 39518.9747380084, -0.00019639754, 0.0000001229439, -5.9724197E-10, _
    1.134611, 14.4235191419, 31676.6099173011, 0.000024767216, 0.0000003087917, -0.000000001420412, 1.085781, 8.8552797618, 5852.6842220465, 0.0000031609367, 0.000000067664088, -2.2006663E-10, -1.0193852, 7.2392703065, 33629.0898976466, -0.000039751134, 0.00000023556127, -1.1256889E-09, -0.8227141, 11.0814572888, 16066.2815125171, 0.00014748204, 0.00000031992438, -1.5697249E-09, _
    0.8042238, 3.527435895, -33.7870573, 0.000028263353, 0.000000037539802, -2.2902113E-10, 0.8025939, 6.7832463846, 16833.1452579809, -0.000099779237, 0.000000027639907, -1.8858767E-10, -0.7931866, -6.382140071, -24462.5470518423, -0.00024326809, -0.00000049525589, 2.2980217E-09, -0.7910153, 6.3703481443, -591.1013369332, -0.00015714346, -0.00000018089785, 8.0295327E-10, _
    -0.6674056, 9.1819266386, 24533.5347274576, 0.000055197395, 0.00000027743463, -0.000000001320487, 0.6502226, 4.1010449356, -10176.3966721553, -0.00030412845, -0.00000043254175, 2.0981718E-09, -0.6388131, 6.2958887075, 25719.1509623392, 0.00023794032, 0.00000049648867, -2.4069012E-09)
m21 = Array( _
    0.0743, 11.9537467337, 6480.986177295, 0.00000049705523, 0.00000006828048, -2.7450635E-10, 0.03043, 8.7259027166, 7737.590087792, -0.0000048307078, 0.000000069513264, -3.8338581E-10, 0.02229, 12.854002651, 15019.2270678508, -0.00027985829, -0.00000019203053, 9.5226618E-10, 0.01999, 15.2095572232, 23347.918492576, -0.00012754553, 0.000000058380585, -2.3407289E-10, _
    0.01869, 9.5981921614, -1847.7052474301, -0.0001518157, -0.00000018213063, 9.1183272E-10, 0.01696, 7.1681781524, 16133.8556271171, 0.000090955337, 0.00000024484477, -1.1116826E-09, 0.01623, 1.584779563, 9061.768112889, -0.000066685176, -4.3335556E-09, -3.4222998E-11, 0.01419, -0.7707750092, 733.0766881638, -0.00021899793, -0.00000025474467, 1.1521161E-09)
m30 = Array( _
385000.5290396, 1.5707963268, 0#, 0#, 0#, 0#, -20905.3551378, 3.926350899, 8328.6914247251, 0.00015231275, 0.00000025041111, -1.1863391E-09, -3699.110933, 9.6121753977, 7214.0628654588, -0.00021850087, -0.00000018646419, 8.7760973E-10, -2955.9675626, 11.9677299699, 15542.754290184, -0.000066188121, 0.000000063946925, -3.0872935E-10, _
  -569.9251264, 6.2819054713, 16657.3828494503, 0.0003046255, 0.00000050082223, -2.3726782E-09, 246.1584797, 7.2566208254, -1114.6285592663, -0.00037081362, -0.0000004368753, 2.0639488E-09, -204.5861179, 12.0108556517, 14914.4523349355, -0.00006352424, 0.000000063330532, -2.5428962E-10, -170.7330791, 14.3232845422, 23871.4457149091, 0.000086124629, 0.00000031435804, -1.4950684E-09, _
  -152.1378118, 9.6553010794, 6585.7609102104, -0.00021583699, -0.00000018708058, 9.3204945E-10, -129.6202242, -0.8278839272, -7700.3894694766, -0.00015497663, -0.00000024979472, 1.1318993E-09, 108.7427014, 6.7692631483, 7771.377145092, -0.000033094061, 0.000000031973462, -1.5436468E-10, 104.7552944, 3.8832252173, 8956.9933799736, 0.00014964887, 0.00000025102751, -1.2407788E-09, _
    79.6605685, 0.6705404095, -8538.2408905558, 0.00028035534, 0.00000026031101, -1.2267725E-09, 48.8883284, 1.527670645, 628.3019552485, -0.0000026638815, 6.1639211E-10, -5.4439728E-11, -34.7825237, 20.0091090408, 22756.8171556428, -0.00028468899, -0.00000012251727, 5.6888037E-10, 30.8238599, 11.9246042882, 16171.0562454324, -0.000068852003, 0.000000064563317, -3.6316908E-10, _
    24.2084985, 9.5690497159, 7842.3648207073, -0.00022116475, -0.0000001858478, 0.00000000082317, -23.2104305, 8.6374600436, 24986.0742741754, 0.00045693825, 0.00000075123334, -3.5590172E-09, -21.6363439, 17.6535544685, 14428.1257309177, -0.00043700174, -0.00000037292838, 1.7552195E-09, -16.6747239, 6.7261374666, 8399.6791003405, -0.000035757942, 0.000000032589854, -2.088044E-10, _
    14.402689, 4.9010662531, -9443.3199839914, -0.00052312637, -0.00000068728642, 3.2502879E-09, -12.8314035, 14.3664102239, 23243.1437596606, 0.000088788511, 0.00000031374165, -1.4406287E-09, -11.6499478, 22.364663613, 31085.5085803679, -0.00013237624, 0.00000012789385, -6.174587E-10, -10.4447578, 16.6788391144, 32200.1371396342, 0.00023843738, 0.00000056476915, -2.6814075E-09, _
    10.3211071, 8.7119194804, -1324.178025097, 0.000061854469, 0.00000007384682, -3.4916281E-10, 10.0562033, 7.2997465071, -1742.9305145148, -0.00036814974, -0.0000004374917, 2.1183885E-09, -9.8844667, 12.0539813334, 14286.150379687, -0.000060860358, 0.00000006271414, -1.998499E-10, 8.7515625, 6.3563649081, -9652.8694498221, -0.000090458282, -0.00000017656429, 8.3717626E-10, _
    -8.3791067, 4.4137085761, -557.3142796331, -0.00018540681, -0.00000021843765, 1.0319744E-09, -7.0026961, -3.1834384995, -16029.0808942018, -0.00030728938, -0.00000050020584, 2.3182384E-09, 6.3220032, 9.1248177206, 16100.0685698171, 0.00011921869, 0.00000028238458, -1.3407038E-09, 5.7508579, 6.2387797896, 17285.6848046987, 0.00030196162, 0.00000050143862, -2.4271179E-09, _
    -4.9501349, 9.6984267611, 5957.4589549619, -0.00021317311, -0.00000018769697, 9.8648918E-10, -4.421177, 3.0260949818, -209.5494658307, 0.00043266809, 0.00000051072212, -2.4131116E-09, 4.1311145, 11.0674740526, 7004.5133996281, 0.00021416722, 0.00000032425793, -1.5355019E-09, -3.9579827, 20.0522347225, 22128.5152003943, -0.00028202511, -0.00000012313366, 6.233201E-10, _
    3.2582371, 14.8106422192, 14985.4400105508, -0.00025159493, -0.00000015449073, 7.2324505E-10, -3.148302, 4.8266068163, 16866.932315281, -0.00012804259, -9.8998954E-09, 4.0433461E-11, 2.6164092, 14.2801588604, 24499.7476701576, 0.000083460748, 0.00000031497443, -1.5495082E-09, 2.353631, 9.5259240342, 8470.6667759558, -0.00022382863, -0.00000018523141, 7.6873027E-10, _
    -2.1171283, -0.871009609, -7072.0875142282, -0.00015764051, -0.00000024917833, 1.0774596E-09, -1.8970368, 17.6966801503, 13799.8237756692, -0.00043433786, -0.00000037354477, 1.8096592E-09, -1.7385258, 2.0581540038, -8886.0057043583, -0.00033771956, -0.00000046884877, 2.2183135E-09, -1.5713944, 22.4077892948, 30457.2066251194, -0.00012971236, 0.00000012727746, -5.6301898E-10, _
    -1.4225541, 24.7202181853, 39414.200005093, 0.000019936508, 0.00000037830496, -1.8037978E-09, -1.4189284, 17.1661967915, 23314.1314352759, -0.000099282182, 0.000000095920387, -4.6309403E-10, 1.1655364, 3.8400995356, 9585.2953352221, 0.00014698499, 0.0000002516439, -1.2952185E-09, -1.1169371, 10.9930146158, 33314.7656989005, 0.000609251, 0.0000010016445, -4.7453563E-09, _
    1.0656723, 1.4845449633, 1256.603910497, -0.000005327763, 1.2327842E-09, -1.0887946E-10, 1.058619, 11.9220903668, 8364.7398411275, -0.00021850087, -0.00000018646419, 8.7760973E-10, -0.9333176, 9.0816920389, 16728.3705250656, 0.00011655481, 0.00000028300097, -1.3951435E-09, 0.8624328, 12.455087647, 6656.7485858257, -0.00040390768, -0.00000040490184, 1.9095841E-09, _
    0.8512404, 4.3705828944, 70.9876756153, -0.00018807069, -0.00000021782126, 9.7753467E-10, -0.8488018, 16.7219647962, 31571.8351843857, 0.00024110126, 0.00000056415276, -2.6269678E-09, -0.7956264, 3.5134526588, -9095.555170189, 0.000094948529, 0.000000041873358, -1.9479814E-10)
m31 = Array( _
    0.51395, 12.0108556517, 14914.4523349355, -0.00006352424, 0.000000063330532, -2.5428962E-10, 0.38245, 9.6553010794, 6585.7609102104, -0.00021583699, -0.00000018708058, 9.3204945E-10, 0.32654, 3.9694765808, 7700.3894694766, 0.00015497663, 0.00000024979472, -1.1318993E-09, 0.26396, 0.7416325637, 8956.9933799736, 0.00014964887, 0.00000025102751, -1.2407788E-09, _
    0.12302, -1.6139220085, 628.3019552485, -0.0000026638815, 6.1639211E-10, -5.4439728E-11, 0.07754, 8.7830116346, 16171.0562454324, -0.000068852003, 0.000000064563317, -3.6316908E-10, 0.06068, 6.4274570623, 7842.3648207073, -0.00022116475, -0.0000001858478, 0.00000000082317, 0.0497, 12.0539813334, 14286.150379687, -0.000060860358, 0.00000006271414, -1.998499E-10)
'//月球平黄经系数
M1n = Array(3.81034392032, 8399.68473021, -3.31919929753E-05, 3.20170955005E-08, -1.53637455544E-10)

' //==================节气计算===================
' //节气表
jqb = Array( _
  "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", _
  "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至", "小寒", "大寒", "立春", "雨水", "惊蛰")
' //==================农历日期===================
yueMing = Array("正", "二", "三", "四", "五", "六", "七", "八", "九", "十", "11", "12")
End Function
'***************************
'============自定义函数====
Function asin(value As Double) As Double
If Abs(value) <> 1 Then
asin = Atn(value / Sqr(1 - value * value))
Else
asin = 1.5707963267949 * Sgn(value)
End If
End Function

'Function asin(x As Double) As Double
'    If (1 - x * x) <= 0 Then
'
'    Else
'        asin = Atn(x / Sqr(1 - x * x))
'    End If
'End Function
'--------------------------
Function Atan2(numY, numX) As Double
    If numX > 0 Then
        Atan2 = Atn(numY / numX)
    ElseIf numX = 0 Then
        If numY > 0 Then
            Atan2 = pi / 2
        ElseIf numY < 0 Then
            Atan2 = -pi / 2
        End If
    Else
        If numY >= 0 Then
            Atan2 = pi + Atn(numY / numX)
        Else
            Atan2 = Atn(numY / numX) - pi
        End If
    End If
End Function
'----------------------------
'求余数(非整数余数)
Function mmod(num1 As Double, num2 As Double) As Double
Dim num As Double
num = (num1 / num2)
num = (num - Int(num)) * num2
mmod = num
End Function
'=================================

'窗体代码
Option Explicit
Dim EnnT, MnnT
'//========角度变换===============
Function int2(ByVal v As Double) As Long            '//取整数部分
  v = Int(v)
  If v < 0 Then
  int2 = v + 1
  Else
  int2 = v
  End If
End Function
Function rad2mrad(v As Double)              '//对超过0-2PI的角度转为0-2PI
  v = mmod(v, (2 * pi))
  rad2mrad = v
  If v < 0 Then rad2mrad = v + 2 * pi
End Function
'----------------------
Function rad2str(d As Double, tim As Integer)  '{ //将弧度转为字串
'//tim=0输出格式示例: -23°59' 48.23"
'//tim=1输出格式示例:  18h 29m 44.52s
Dim A As Double, B As Double, C As Double
Dim s$, w1$, w2$, w3$
Dim a1$, b1$, c1$, d1$
  s = "+"
  w1 = "°": w2 = "'": w3 = """"
If d < 0 Then d = -d: s = "-"
If tim Then
  d = d * 12 / pi: w1 = "h ": w2 = "m ": w3 = "s "
Else
d = d * 180 / pi
End If
  A = Int(d): d = (d - A) * 60
  B = Int(d): d = (d - B) * 60
  C = Int(d): d = (d - C) * 100
d = Int(d + 0.5)
If d >= 100 Then d = d - 100: C = C + 1
If C >= 60 Then C = C - 60: B = B + 1
If B >= 60 Then B = B - 60: A = A + 1
a1 = "  " & A: b1 = "0" & B: c1 = "0" & C: d1 = "0" & d
Debug.Print a1 & vbCrLf & b1 & vbCrLf & c1 & vbCrLf & d1 & vbCrLf
s = s & Mid(a1, Len(a1) - 2, 3) & w1
s = s & Mid(b1, Len(b1) - 1, 2) & w2
s = s & Mid(c1, Len(c1) - 1, 2) & "."
s = s & Mid(d1, Len(d1) - 1, 2) & w3
rad2str = s
End Function

'//================日历计算===============
Function deltatT(y)  ' //计算世界时与原子时之差,传入年
  Dim i%, d
  Dim t1#, t2#, t3#
  d = jdate.dts
  For i = 0 To 100 Step 5
    If y < d(i + 5) Or i = 95 Then Exit For
    Next
    t1 = (y - d(i)) / (d(i + 5) - d(i)) * 10: t2 = t1 * t1: t3 = t2 * t1
  deltatT = d(i + 1) + d(i + 2) * t1 + d(i + 3) * t2 + d(i + 4) * t3
End Function
'///////////////
Function deltatT2(jd)  ' //传入儒略日(J2000起算),计算UTC与原子时的差(单位:日)
    deltatT2 = deltatT(jd / 365.2425 + 2000) / 86400#
End Function
'**************
'////////////////////
Function toJD(UTC As Double) As Double  '{ //公历转儒略日,UTC=1表示原日期是UTC
    Dim y%, mon%, n#
    y = jdate.y: mon = jdate.mon: n = 0 ' //取出年月
  If mon <= 2 Then mon = mon + 12: y = y - 1
  If CLng(jdate.y) * 372 + jdate.mon * 31 + jdate.d >= 588829 Then '//判断是否为格里高利历日1582*372+10*31+15
    n = int2(y / 100): n = 2 - n + int2(n / 4) '//加百年闰
    End If
  n = n + int2(365.2500001 * (y + 4716)) '  //加上年引起的偏移日数
  n = n + int2(30.6 * (mon + 1)) + jdate.d '      //加上月引起的偏移日数及日偏移数
  n = n + ((jdate.s / 60 + jdate.m) / 60 + jdate.h) / 24 - 1524.5
  toJD = n
  If UTC Then toJD = n + deltatT2(n - j2000)
  End Function
'////////////////////
'***UTC=0儒略日转公历，在jdate.y....
Function setFromJD(ByVal jd, UTC)    '{ //儒略日数转公历,UTC=1表示目标公历是UTC
    If UTC Then jd = jd - deltatT2(jd - j2000)
    jd = jd + 0.5
    Dim A As Long, F As Double
    A = int2(jd): F = jd - A: Dim d As Long                '  //取得日数的整数部份A及小数部分F
    If A > 2299161 Then d = int2((A - 1867216.25) / 36524.25): A = A + 1 + d - int2(d / 4)
    A = A + 1524                                          ' //向前移4年零2个月
    jdate.y = int2((A - 122.1) / 365.25)                  '//年
    d = A - int2(365.25 * jdate.y)                        ' //去除整年日数后余下日数
    jdate.mon = int2(d / 30.6001)                          '      //月数
    jdate.d = d - int2(jdate.mon * 30.6001)                '//去除整月日数后余下日数
    jdate.y = jdate.y - 4716: jdate.mon = jdate.mon - 1
    If jdate.mon > 12 Then jdate.mon = jdate.mon - 12
    If jdate.mon <= 2 Then jdate.y = jdate.y + 1
    '  //日的小数转为时分秒
    F = F * 24: jdate.h = int2(F): F = F - jdate.h
    F = F * 60: jdate.m = int2(F): F = F - jdate.m
    F = F * 60: jdate.s = F
End Function
'//////////////////////
Function setFromStr(s)    '{ //设置时间,参数例:"20000101 120000"或"20000101"
    jdate.y = Val(Mid(s, 1, 4)): jdate.mon = Val(Mid(s, 5, 2)): jdate.d = Val(Mid(s, 7, 2))
    jdate.h = Val(Mid(s, 10, 2)): jdate.m = Val(Mid(s, 12, 2)): jdate.s = Val(Mid(s, 14, 5))
End Function
'////////////////////////
Function toStr() '{ //日期转为串
Dim ymd$, hms$
Dim h%, m%, s!
ymd = jdate.y & "-" & Format(Abs(jdate.mon), "00") & "-" & Format(Abs(jdate.d), "00")
'y = "    " & jdate.y: mon = "0" & jdate.mon: D = "0" & jdate.D
h = Abs(jdate.h): m = Abs(jdate.m): s = Abs(Int(jdate.s + 0.5))
If s >= 60 Then s = s - 60: m = m + 1
If m >= 60 Then m = m - 60: h = h + 1
hms = Format(h, "00:") & Format(m, "00:") & Format(s, "00")

'h = "0" & h: m = "0" & m: s = "0" & s
'y = Mid(y, Len(y) - 4, 5): mon = Mid(mon, Len(mon) - 1, 2): D = Mid(D, Len(D) - 1, 2)
'h = Mid(h, Len(h) - 1, 2): m = Mid(m, Len(m) - 1, 2): s = Mid(s, Len(s) - 1, 2)
'toStr = y & "-" & mon & "-" & D & " " & h & ":" & m & ":" & s
toStr = ymd & " " & hms
End Function
'///////////////////////////////////
Function Dint_dec(jd, shiqu, int_dec) '{ //算出:jd转到当地UTC后,UTC日数的整数部分或小数部分
'//基于J2000力学时jd的起算点是12:00:00时,所以跳日时刻发生在12:00:00,这与日历计算发生矛盾
'//把jd改正为00:00:00起算,这样儒略日的跳日动作就与日期的跳日同步
'//改正方法为jd=jd+0.5-deltatT+shiqu/24
'//把儒略日的起点移动-0.5(即前移12小时)
'//式中shiqu是时区,北京的起算点是-8小时,shiqu取8
Dim u#
u = jd + 0.5 - deltatT2(jd) + shiqu / 24
If int_dec Then
Dint_dec = Int(u) ' //返回整数部分
Else
Dint_dec = u - Int(u) '      //返回小数部分
End If
End Function
'///////////////////////////
Function d1_d2(d1, d2) '{ //计算两个日期的相差的天数,输入字串格式日期,如:"20080101"
Dim y%, mon%, d%, h%, m%, s!
Dim jd1#, jd2#
y = jdate.y: mon = jdate.mon: d = jdate.d: h = jdate.h: m = jdate.m: s = jdate.s ' //备份原来的数据
setFromStr (Mid(d1, 1, 8) & " 120000"):  jd1 = toJD(0)
setFromStr (Mid(d2, 1, 8) & " 120000"):  jd2 = toJD(0)
jdate.y = y: jdate.mon = mon: jdate.d = d: jdate.h = h: jdate.m = m: jdate.s = s ' //还原
If jd1 > jd2 Then
d1_d2 = Int(jd1 - jd2 + 0.0001)
Else
d1_d2 = -Int(jd2 - jd1 + 0.0001)
End If
End Function
'///////////////////////////////////
'//=========黄赤交角及黄赤坐标变换===========

Function hcjj1(t)  ' //返回黄赤交角(常规精度),短期精度很高
Dim t1#, t2#, t3#
  t1 = t / 36525: t2 = t1 * t1: t3 = t2 * t1
hcjj1 = (hcjjb(0) + hcjjb(1) * t1 + hcjjb(2) * t2 + hcjjb(3) * t3) / rad
End Function
'////////////////////////////////
Function HCconv(JW, e)    '{ //黄赤转换(黄赤坐标旋转)
'  //黄道赤道坐标变换,赤到黄E取负
Dim hj#, hw#, sinE#, sinW#, cosE#, J#
  hj = rad2mrad(CDbl(JW(0))): hw = JW(1)
  sinE = Sin(e): cosE = Cos(e)
  sinW = cosE * Sin(hw) + sinE * Cos(hw) * Sin(hj)
  J = Atan2(Sin(hj) * cosE - Tan(hw) * sinE, Cos(hj))
  JW(0) = rad2mrad(J)
  JW(1) = asin(sinW)
End Function

'接上
'/////////////////////////////
Function addPrece(jd, zb) ' //补岁差
Dim i%, t#, t1#, v#
t = 1: v = 0: t1 = jd / 365250
For i = 1 To 7
t = t * t1: v = v + preceB(i) * t
Next
zb(0) = rad2mrad(zb(0) + (v + CDbl(2.9965 * t1)) / rad)
End Function
'//////////////////////////
'//===============光行差==================
Function addGxc(t, zb)  '//恒星周年光行差计算(黄道坐标中)
Dim t1#, t2#, t3#, t4#, l#, p#, e#, dl#, dp#
  t1 = t / 36525: t2 = t1 * t1: t3 = t2 * t1: t4 = t3 * t1
  l = GXC_l(0) + GXC_l(1) * t1 + GXC_l(2) * t2 + GXC_l(3) * t3 + GXC_l(4) * t4
  p = GXC_p(0) + GXC_p(1) * t1 + GXC_p(2) * t2
  e = GXC_e(0) + GXC_e(1) * t1 + GXC_e(2) * t2
  dl = l - zb(0): dp = p - zb(0)
  zb(0) = zb(0) - GXC_k * (Cos(dl) - e * Cos(dp)) / Cos(zb(1))
  zb(1) = zb(1) - GXC_k * Sin(zb(1)) * (Sin(dl) - e * Sin(dp))
  zb(0) = rad2mrad(CDbl(zb(0)))
End Function

'//===============章动计算==================
Function nutation(t) As Variant  ' //计算黄经章动及交角章动
    Dim i%, C#, t1#, t2#, t3#, t4#, t5#
    Dim dlon#, dobl#, d(0 To 1) As Double
    d(0) = 0: d(1) = 0: t = t / 36525
      t1 = t: t2 = t1 * t1: t3 = t2 * t1: t4 = t3 * t1: t5 = t4 * t1
    For i = 0 To UBound(nutB) Step 9
        C = nutB(i) + nutB(i + 1) * t1 + nutB(i + 2) * t2 + nutB(i + 3) * t3 + nutB(i + 4) * t4
    d(0) = d(0) + (nutB(i + 5) + nutB(i + 6) * t / 10) * Sin(C)  ' //黄经章动
    d(1) = d(1) + (nutB(i + 7) + nutB(i + 8) * t / 10) * Cos(C)  ' //交角章动
    Next
    d(0) = d(0) / (rad * (10000)) ' //黄经章动)
    d(1) = d(1) / (rad * (10000))  ' //交角章动
    nutation = d
End Function
Function nutationRaDec(t, zb) ' //本函数计算赤经章动及赤纬章动
Dim Ra#, Dec#, e#, sinE#, cosE#, d As Variant
Dim cosRa#, sinRa#, tanDec#
Ra = zb(0): Dec = zb(1)
e = hcjj1(t): sinE = Sin(e): cosE = Cos(e) ' //计算黄赤交角
d = nutation(t)                            '  //计算黄经章动及交角章动
cosRa = Cos(Ra): sinRa = Sin(Ra)
tanDec = Tan(Dec)
zb(0) = zb(0) + (cosE + sinE * sinRa * tanDec) * d(0) - cosRa * tanDec * d(1) ' //赤经章动
zb(1) = zb(1) + sinE * cosRa * d(0) + sinRa * d(1) '  //赤纬章动
zb(0) = rad2mrad(CDbl(zb(0)))
End Function

'//==================日位置计算===================
'var EnnT=0; //调用Enn前先设置EnnT时间变量
Function Enn(F) '{ //计算E10,E11,E20等,即:某一组周期项或泊松项算出,计算前先设置EnnT时间
    Dim i%, v#
    v = 0
    For i = 0 To UBound(F) Step 3
        v = v + F(i) * Cos(F(i + 1) + EnnT * F(i + 2))
    Next
    Enn = v
End Function
Function earCal(jd) As Variant    '//返回地球位置,日心Date黄道分点坐标
    Dim llr(0 To 2) As Double
    Dim t1#, t2#, t3#, t4#, t5#
    EnnT = jd / (365250)
    t1 = EnnT: t2 = t1 * t1: t3 = t2 * t1: t4 = t3 * t1: t5 = t4 * t1
    llr(0) = Enn(e10) + Enn(e11) * t1 + Enn(e12) * t2 + Enn(e13) * t3 + Enn(e14) * t4 + Enn(e15) * t5
    llr(1) = Enn(e20) + Enn(e21) * t1
    llr(2) = Enn(e30) + Enn(e31) * t1 + Enn(e32) * t2 + Enn(e33) * t3
    llr(0) = rad2mrad(llr(0))
    earCal = llr
End Function
Function sunCal2(jd) As Variant ' //传回jd时刻太阳的地心视黄经及黄纬
  Dim sun As Variant, d As Variant
  sun = earCal(jd): sun(0) = sun(0) + pi: sun(1) = -sun(1) ' //计算太阳真位置
  d = nutation(jd): sun(0) = rad2mrad(sun(0) + d(0)) ' //补章动
Call addGxc(jd, sun) '  //补周年黄经光行差
  sunCal2 = sun '      //返回太阳视位置
End Function
'//==================月位置计算===================
'var MnnT=0; //调用Mnn前先设置MnnT时间变量
Function Mnn(F) ' //计算M10,M11,M20等,计算前先设置MnnT时间
    'MnnT = 0
    Dim i%, t1#, t2#, t3#, t4#, v#
    v = 0: t1 = MnnT: t2 = t1 * t1: t3 = t2 * t1: t4 = t3 * t1
    For i = 0 To UBound(F) Step 6
        v = v + F(i) * Sin(F(i + 1) + t1 * F(i + 2) + t2 * F(i + 3) + t3 * F(i + 4) + t4 * F(i + 5))
    Next
    Mnn = v
End Function
Function moonCal(jd) As Variant  '{//返回月球位置,返回地心Date黄道坐标
  Dim t1#, t2#, t3#, t4#, v#
  MnnT = jd / 36525
  t1 = MnnT: t2 = t1 * t1: t3 = t2 * t1: t4 = t3 * t1
  Dim llr(0 To 2) As Double
  llr(0) = (Mnn(m10) + Mnn(m11) * t1 + Mnn(m12) * t2) / rad
  llr(1) = (Mnn(m20) + Mnn(m21) * t1) / rad
  llr(2) = (Mnn(m30) + Mnn(m31) * t1) * 0.999999949827
  llr(0) = llr(0) + M1n(0) + M1n(1) * t1 + M1n(2) * t2 + M1n(3) * t3 + M1n(4) * t4
  llr(0) = rad2mrad(llr(0)) ' //地心Date黄道原点坐标(不含岁差)
  Call addPrece(jd, llr) ' //补岁差
  moonCal = llr
End Function
Function moonCal2(jd) ' //传回月球的地心视黄经及视黄纬
  Dim d As Variant, moon As Variant
  moon = moonCal(jd)
  d = nutation(jd)
  moon(0) = rad2mrad(moon(0) + d(0)) ' //补章动
  moonCal2 = moon
End Function
Function moonCal3(jd) ' //传回月球的地心视赤经及视赤纬
  Dim moon As Variant
  moon = moonCal(jd)
  Call HCconv(moon, hcjj1(jd))
  Call nutationRaDec(jd, moon) ' //补赤经及赤纬章动
' //如果黄赤转换前补了黄经章动及交章动,就不能再补赤经赤纬章动
  moonCal3 = moon
End Function
'//==================地心坐标中的日月位置计算===================
Function jiaoCai(lx, ByVal t, jiao)  '{
  '//lx=1时计算t时刻日月角距与jiao的差, lx=0计算t时刻太阳黄经与jiao的差
  Dim sun As Variant, d As Variant, moon As Variant
  sun = earCal(t) '  //计算太阳真位置(先算出日心坐标中地球的位置)
  sun(0) = sun(0) + pi: sun(1) = -sun(1) ' //转为地心坐标
  Call addGxc(t, sun)    ' //补周年光行差
  If lx = 0 Then '{
    d = nutation(t): sun(0) = sun(0) + d(0) ' //补黄经章动
    jiaoCai = rad2mrad(jiao - sun(0))
Else
  moon = moonCal(t) ' //日月角差与章动无关
  jiaoCai = rad2mrad(jiao - (moon(0) - sun(0)))
End If
End Function
'//==================已知位置反求时间===================+++++++++++++++++++++++++
Function jiaoCal(t1, jiao, lx)    '{ //t1是J2000起算儒略日数
    '//已知角度(jiao)求时间(t)
    '//lx=0是太阳黄经达某角度的时刻计算(用于节气计算)
    '//lx=1是日月角距达某角度的时刻计算(用于定朔望等)
    '//传入的t1是指定角度对应真时刻t的前一些天
    '//对于节气计算,应满足t在t1到t1+360天之间,对于Y年第n个节气(n=0是春分),t1可取值Y*365.2422+n*15.2
    '//对于朔望计算,应满足t在t1到t1+25天之间,在此范围之外,求右边的根

    Dim t#, t2#
    Dim v#, v1#, v2#, k#, k2#, i%
    t2 = t1: t = 0:
    If lx = 0 Then
        t2 = t2 + 360                                      '  //在t1到t2范围内求解(范气360天范围),结果置于t
    Else
        t2 = t2 + 25
    End If
    jiao = jiao * (pi / 180)                              '  //待搜索目标角
    '//利用截弦法计算
    v1 = jiaoCai(lx, t1, jiao)                            '          //v1,v2为t1,t2时对应的黄经
    v2 = jiaoCai(lx, t2, jiao)
    'ric.Text = ric.Text & v1 & vbCrLf
    If v1 < v2 Then v2 = v2 - 2 * pi                      '    //减2pi作用是将周期性角度转为连续角度
    k = 1                                                  '  //k是截弦的斜率
    For i = 0 To 9                                        '{      //快速截弦求根,通常截弦三四次就已达所需精度
        k2 = (v2 - v1) / CDbl((t2 - t1))                  '    //算出斜率
        If Abs(k2) > (0.000000000000001) Then k = k2      '    //差商可能为零,应排除
        t = t1 - v1 / k: v = jiaoCai(lx, t, jiao)          '//直线逼近法求根(直线方程的根)
        If v > 1 Then v = v - 2 * pi                      '        //一次逼近后,v1就已接近0,如果很大,则应减1周
        If Abs(v) < (0.00000001) Then Exit For            '      //已达精度
        t1 = t2: v1 = v2: t2 = t: v2 = v                  '          //下一次截弦
    Next
    jiaoCal = t
End Function
'//==================节气计算===================
'var jqB=new Array( //节气表
'  "春分","清明","谷雨","立夏","小满","芒种","夏至","小暑","大暑","立秋","处暑","白露",
'  "秋分","寒露","霜降","立冬","小雪","大雪","冬至","小寒","大寒","立春","雨水","惊蛰");

Function JQtest(y) '{ //节气使计算范例,y是年分,这是个测试函数++++++++++++++++++++++++++++++
  Dim i%, jd#
  Dim q#, s1$, s2$
  jd = 365.2422 * (y - 2000)
ric.Text = ric.Text & "节气:世界时  原子时" & vbCrLf
  'document.write("节气:世界时  原子时
");
  For i = 0 To 23  '{
    q = jiaoCal(jd + i * 15.2, i * 15, 0) + j2000 + 8 / 24 '  //计算第i个节气(i=0是春风),结果转为北京时
    Call setFromJD(q, 1): s1 = toStr() '  //将儒略日转成世界时
    Call setFromJD(q, 0): s2 = toStr() '  //将儒略日转成日期格式(输出日期形式的力学时)
  'document.write(jqB[i]+" : "+s1+" "+s2+"
"); //显示
ric.Text = ric.Text & jqb(i) & ":" & s1 & " " & s2 & vbCrLf
  Next
End Function
'//=================定朔弦望计算========================
Function dingSuo(y, arc) '{ //这是个测试函数
  Dim i: jd = 365.2422 * (y - 2000): Dim q, s1, s2
  'document.write("月份:世界时  原子时
");
  For i = 0 To 12  '{
    q = jiaoCal(jd + 29.5 * i, arc, 1) + j2000 + 8 / 24 '  //计算第i个节气(i=0是春风),结果转为北京时
  Call setFromJD(q, 1): s1 = toStr() '//将儒略日转成世界时
    Call setFromJD(q, 0): s2 = toStr() '  //将儒略日转成日期格式(输出日期形式的力学时)
  ' document.write((i+1)+"月 : "+s1+" "+s2+"
"); //显示
  Next
End Function
'//=================农历计算========================
'/*****
'  1.冬至所在的UTC日期保存在A[0],根据"规定1"得知在A[0]之前(含A[0])的那个UTC朔日定为年首日期
'    冬至之后的中气分保存在A[1],A[2],A[3]...A[13],其中A[12]又回到了冬至,共计算13次中气
'  2.连续计算冬至后14个朔日,即起算时间时A[0]+1
'    14个朔日编号为0,1...12,保存在C[0],C[1]...C[13]
'    这14个朔日表示编号为0月,1月,...12月0月的各月终止日期,但要注意实际终止日是新月初一,不属本月
'    这14个朔日同样表示编号为1月,2月...的开始日期
'    设某月编号为n,那么开始日期为C[n-1],结束日期为C[n],如果每月都含中气,该月所含的中气为A[n]'
'注:    为了全总计算出13个月的大小月情况 , 须算出14个朔日?
'  3.闰年判断:含有13个月的年份是闰年
'    当第13月(月编号12月)终止日期大于冬至日,  即C[12]〉A[12], 那么该月是新年,本年没月12月,本年共12个月
'    当第13月(月编号12月)终止日期小等于冬至日,即C[12]≤A[12],那么该月是本年的有效月份,本年共13个月
'  4.闰年中处理闰月:
'    13个月中至少1个月份无中气,首个无中气的月置闰,在n=1...12月中找到闰月,即C[n]≤A[n]
'    从农历年首的定义知道,0月一定含有中气冬至,所以不可能是闰月。
'    首月有时很贪心 , 除冬至外还可能再吃掉本年或前年的另一个中气
'    定出闰月后 , 该月及以后的月编号减1
'  5.以上所述的月编号不是日常生活中说的"正月","二月"等月名称:
'    如果"建子",0月为首月,如果"建寅",2月的月名"正月",3月是"二月",其余类推
'*****/
'var yueMing=new Array("正","二","三","四","五","六","七","八","九","十","11","12");
Function paiYue()    '{ //农历排月序计算,可定出农历
    Dim y&
    'y=in1.value-0;
    y = Val(Text1.Text)
    Dim zq(), jq(), hs()                                  '  //中气表,节气表,日月合朔表
    '//从冬至开始,连续计算14个中气时刻
    Dim i, t1: t1 = 365.2422 * (y - 2000) - 50            ' //农历年首始于前一年的冬至,为了节气中气一起算,取前年大雪之前
    For i = 0 To 13                                        '{  //计算节气(从冬至开始),注意:返回的是力学时
        ReDim Preserve zq(i): ReDim Preserve jq(i)
        zq(i) = jiaoCal(t1 + i * 30.4, i * 30 - 90, 0)    ' //中气计算,冬至的太阳黄经是270度(或-90度)
        jq(i) = jiaoCal(t1 + i * 30.4, i * 30 - 105, 0)    ' //顺便计算节气,它不是农历定朔计算所必需的
    Next
    '//在冬至过后,连续计算14个日月合朔时刻
    Dim dongZhiJia1
    dongZhiJia1 = zq(0) + 1 - Dint_dec(zq(0), 8, 0)        ' //冬至过后的第一天0点的儒略日数
    ReDim Preserve hs(0)
    hs(0) = jiaoCal(dongZhiJia1, 0, 1)                    ' //首月结束的日月合朔时刻
    For i = 1 To 13
        ReDim Preserve hs(i)
        hs(i) = jiaoCal(hs(i - 1) + 25, 0, 1)
    Next
    '//算出中气及合朔时刻的日数(不含小数的日数计数,以便计算日期之间的差值)
    Dim A(), B(), C()
    For i = 0 To 13                                        '{ //取当地UTC日数的整数部分
        ReDim Preserve A(i): ReDim Preserve B(i): ReDim Preserve C(i)
        A(i) = Dint_dec(zq(i), 8, 1)
        B(i) = Dint_dec(jq(i), 8, 1)
        C(i) = Dint_dec(hs(i), 8, 1)
    Next
    '//闰月及大小月分析
    Dim tot, nun, yn(), k
    tot = 12: nun = -1: yn = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 0, 0)    ' //月编号
    If C(12) <= A(12) Then                                '{ //闰月分析
        yn(12) = 12: tot = 13                              '  //编号为12的月是本年的有效月份,本年总月数13个
        For i = 1 To 13
            If C(i) <= A(i) Then Exit For
        Next
        nun = i - 1
            For k = i To 12
                yn(k - 1) = yn(k - 1) - 1        ' //注意yn中不含农历首月(所以取i-1),在公历中农历首月总是去年的所以不多做计算
      Next
    End If
    For i = 0 To 12                                        '{ //转为建寅月名,并做大小月分析
        yn(i) = yueMing(mmod((yn(i) + 10), 12))            '                    //转建寅月名
        If i = nun Then
            yn(i) = yn(i) & "闰"
        Else
            yn(i) = yn(i) & "月"                            ' //标记是否闰月
        End If
        If C(i + 1) - C(i) > 29 Then
            yn(i) = yn(i) & "大"
        Else
            yn(i) = yn(i) & "小"                            ' //标记大小月
        End If
    Next
    '//显示
    Dim out
    out = " 节气    手表时          中气    手表时          农历月  朔的手表时" & vbCrLf
    Dim zm, jm
    For i = 0 To tot - 1                                  '{
        zm = mmod((i * 2 + 18), 24): jm = mmod((i * 2 + 17), 24)    ' //中气名节气名
        Call setFromJD(jq(i) + j2000 + 8 / 24, 1): out = out & jqb(jm) & ":" & toStr() & " "    ' //显示节气
        Call setFromJD(zq(i) + j2000 + 8 / 24, 1): out = out & jqb(zm) & ":" & toStr() & " "    ' //显示中气
        Call setFromJD(hs(i) + j2000 + 8 / 24, 1): out = out & yn(i) & ":" & toStr() & vbCrLf    ' //显示日月合朔
    Next
    ric.Text = ric.Text & out & vbCrLf
End Function
'////////////////////////////

Private Sub Command1_Click()
ric.Text = ""
Call paiYue
End Sub


Private Sub Form_Load()
ric.Text = ""
Text1.Text = "2011"
Call setvalue
Call ydlist
End Sub

很好，辛苦了。
很有条理，可读性强；
不知道能不能将“节气计算”部分的javascript代码整理出来？
我很想弄清《寿星天文历》的节气算法，但学艺不精，没法从中提取出跟“节气计算”有关的代码。

谢谢楼主！

贴出的代码其实就是许剑伟先生公布的javascript---"基于JavaScript的精准农历计算程序"。原文地址：http://bbs.nongli.net/dispbbs_2_10840_0_2.html

除了VB6里没有的几个函数是自己加的，其它都是许剑伟先生那段代码的全文VB6翻译。。。。。
另外，因为是用天文算法推算，所以那些章动、行差之类的都是必要参数，没法省的。

而且这段代码应该就是许先生寿星历的最简版，主要就是各节气和朔望计算，朔定了，其它的就迎刃而解，建议你在VB6里试下。真正的运行代码只有最后两段，其它都是函数。。。
希望能帮到你。。。

补充说明（使用方法）：
VB6新建工程后，添加一模块，然后将模块代码全部复制进去，打开窗体代码窗口，把窗体代码全部复制进去。
分别添加一Command1控件，一Text1控件，一RichTextBox1控件改名为 ric 即可。其中，Text1用于输入年份，ric用于显示计算内容。

代码说明：
1、节气计算：
函数Function JQtest(y)  'VB6调用代码为Call JQtest (Text1.Text) 或者 Call JQtest (2012)
其中：
For i = 0 To 23 ' ----i为节气表序号
q = jiaoCal(jd + i * 15.2, i * 15, 0) + j2000 + 8 / 24 ' -------q为i节气计算后的儒略日
Call setFromJD(q, 1) '------- 调用函数setFromJD将节气儒略日q转换为公历日期时间格式，并设置入自定义日期时间存储变量jdate中。(q,1)为世界时，(q,0)为力学时。
s1 = toStr() ' ----------调用函数toStr，从jdate中以日期时间的字符串形式取出i节气公历日期。
Call setFromJD(q, 0): s2 = toStr() ' 同上
ric.Text = ric.Text & jqb(i) & ":" & s1 & " " & s2 & vbCrLf ' 读入ric.Text 中。
Next
＝＝＝＝＝＝＝＝＝＝＝＝＝
2、函数Function dingSuo(y, arc) -------计算y年的朔望上下弦，arc为0则计算朔日。其它同上
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
3、函数Function paiYue() -----计算y年各月节气、中气、大小月、闰月、定朔日。在ric.Text 显示。
其中：y = Val(Text1.Text) 为计算年由Text1.Text输入。
====================

谢谢！按你提供的网址，找到了许先生提供的java代码，正是千寻万觅的好东东。再次谢谢！！

不客气哈，相互交流。。。。

楼主辛苦了 正需要