注册 登录
编程论坛 → VB6论坛

VBS计算指定经纬度地区当天日落时间

yuma 发布于 2022-12-11 10:27， 1999 次点击
转载自：http://www.

前言：
    算法公式是foxjl从网上找来的，本人只是将这种算法用VBS实现而已，没有什么技术含量，也不敢妄称原创。
    代码中的经度和纬度是本人所在地株洲市的，时区是东8区，大家可以修改这三个变量的值来计算各地的日落时间。

程序代码：
Dim JD, WD, Days, SunDown, TimeArea, X, ACOS, Arr, Today
JD = 113.8 '经度，东为正西为负，我国都是东经
WD = 27.55 '纬度，北为正南为负，我国都是北纬
TimeArea = 8 '时区，东正西负，我国有东九、东八、东七、东六、东五五个时区
TodAy = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日"
Days = DateDiff("d", Year(Now) & "-1-1 00:00:00", Now) + 1
X = -TAN(-23.4*COS(2*3.14*(Days+9)/365)*3.14/180)*TAN(WD*3.14/180)
ACOS = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
SunDown = Round(24*(1+(TimeArea*15-JD)/180)-24*(180+TimeArea*15-JD-ACOS*180/3.14)/360, 2)
Arr = Split(SunDown, ".")
SunDown = Arr(0) & ":" & Int((0&"."&Int(Arr(1)))*60)
WScript.Echo "本地" & Today & "的日落时间为：" & SunDown


只能算出日落时间，哪位大神懂日出日落算法，给日出时间加入进去，谢谢！
13 回复
#2
mrexcel2022-12-12 00:04
可参考 https://zhuanlan.
#3
yuma2022-12-12 10:19
回复 2楼 mrexcel
我要是能看的懂这代数式那就历害了。
#4
mrexcel2022-12-12 16:16
程序代码：
Function Suntime(ByVal lon As Single, ByVal lat As Single) As String
Dim Days&, X As Single, s(1)
Days = Date - DateSerial(Year(Date), 1, 0)
X = -Tan(-23.4 * Cos(8 * Atn(1) * (Days + 9) / 365) * Atn(1) / 45) * Tan(lat * Atn(1) / 45)
X = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
s(0) = 4 * (300 - lon - X * 45 / Atn(1))
s(1) = 8 * (300 - lon) - s(0)
Suntime = "日出时间为：" & Format(TimeSerial(0, s(0), 0), "hh:MM") & ",日落时间为：" & Format(TimeSerial(0, s(1), 0), "hh:MM")
End Function

Sub macro1()
Debug.Print Suntime(113.8, 27.55)
End Sub
#5
mrexcel2022-12-12 16:18
日出时间为：07:16,日落时间为：17:33
#6
yuma2022-12-12 19:09
回复 4楼 mrexcel
这样可否？乱改的，日出时间和你差不多。不知我的公式有没有问题。

Dim JD, WD, Days, SunUp, SunDown, TimeArea, X, ACOS, Arr, Today
JD = 113.8 '经度，东为正西为负，我国都是东经
WD = 27.55 '纬度，北为正南为负，我国都是北纬
TimeArea = 8 '时区，东正西负，我国有东九、东八、东七、东六、东五五个时区
TodAy = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日"
Days = DateDiff("d", Year(Now) & "-1-1 00:00:00", Now) + 1
X = -TAN(-23.4*COS(2*3.14*(Days+9)/365)*3.14/180)*TAN(WD*3.14/180)
ACOS = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
SunUp = Round(24*(180+TimeArea*15-JD-ACOS*180/3.14)/360, 2)
SunDown = Round(24*(1+(TimeArea*15-JD)/180)-24*(180+TimeArea*15-JD-ACOS*180/3.14)/360, 2)
Arr = Split(SunUp, ".")
SunUp = Arr(0) & ":" & Int((0 &"."&Int(Arr(1)))*60)
Arr = Split(SunDown, ".")
SunDown = Arr(0) & ":" & Int((0 &"."&Int(Arr(1)))*60)
WScript.Echo "本地" & Today & "的日出时间为：" & SunUp & " 日落时间为：" & SunDown

[此贴子已经被作者于2022-12-12 19:44编辑过]
#7
mrexcel2022-12-12 22:30
以下是引用yuma在2022-12-12 19:09:48的发言：

这样可否？乱改的，日出时间和你差不多。不知我的公式有没有问题。

Dim JD, WD, Days, SunUp, SunDown, TimeArea, X, ACOS, Arr, Today
JD = 113.8 '经度，东为正西为负，我国都是东经
WD = 27.55 '纬度，北为正南为负，我国都是北纬
TimeArea = 8 '时区，东正西负，我国有东九、东八、东七、东六、东五五个时区
TodAy = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日"
Days = DateDiff("d", Year(Now) & "-1-1 00:00:00", Now) + 1
X = -TAN(-23.4*COS(2*3.14*(Days+9)/365)*3.14/180)*TAN(WD*3.14/180)
ACOS = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
SunUp = Round(24*(180+TimeArea*15-JD-ACOS*180/3.14)/360, 2)
SunDown = Round(24*(1+(TimeArea*15-JD)/180)-24*(180+TimeArea*15-JD-ACOS*180/3.14)/360, 2)
Arr = Split(SunUp, ".")
SunUp = Arr(0) & ":" & Int((0 &"."&Int(Arr(1)))*60)
Arr = Split(SunDown, ".")
SunDown = Arr(0) & ":" & Int((0 &"."&Int(Arr(1)))*60)
WScript.Echo "本地" & Today & "的日出时间为：" & SunUp & " 日落时间为：" & SunDown



没什么问题，3.14可以用4*ATN(1)代替
#8
yuma2022-12-13 08:22
回复 7楼 mrexcel
跟你的时间相差1分钟，不知问题出在哪？
#9
mrexcel2022-12-13 09:39
计算公式一样，精度问题。
#10
yuma2022-12-13 10:17
非常感谢！
#11
cwa99582022-12-15 13:02
回复 7楼 mrexcel
牵涉到地球的计算，圆周率用3.14就有问题了
#12
felix3012022-12-17 16:31
Sub 用网抓显示当前电脑所在地和IP和日出日落()  ' 不用人为指定经纬度，网抓经纬度实现
    Dim oHtml As Object
    Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")
    Dim sUrl As String
    '指定要抓取的网站

    sUrl = "https://www.   '网抓地址
    Dim sCharset As String
    '指定要抓取的网站的字符编码
    sCharset = "utf-8"
    With oHtml
        .Open "GET", sUrl, False
        .Send
        '获取返回的字节数组
        bResult = .responsebody
        '按照指定的字符编码显示
        sResult = BByte2String(bResult, sCharset)
        Debug.Print sResult
        Dim STR As String
        经纬度 = Split(Split(sResult, "<span>经纬度</span>")(1), "</li>")(0)           
        IP地址 = Split(Split(sResult, "IP地址</span><a href=""/ip/")(1), ".html")(0)
        所在地址 = Split(Split(sResult, "位置信息</span>")(1), "</li>")(0)
        JD = Split(经纬度, ",")(1)
        WD = Split(经纬度, ",")(0)
    End With
    Set oHtml = Nothing
    MsgBox Suntime(JD, WD) & Chr(10) & "地址: " & 所在地址 & Chr(10) & "IP地址: " & IP地址
End Sub
Function BByte2String(bContent, ByVal sCharset As String)
Const adSaveCreateOverWrite = 2
Const adSaveCreateNotExist = 1
Const adTypeBinary = 1
Const adTypeText = 2
Const adModeRead = 1
Const adModeWrite = 2
Const adModeReadWrite = 3
Dim oStream As Object
'创建流对象
Set oStream = CreateObject("ADODB.Stream")
With oStream
    '打开流
    .Open
    '设置为字节模式
    .Type = adTypeBinary
    '写入字节
    .Write bContent
    '将位置定位在第一个字节
    .Position = 0
    '设置为文本模式
    .Type = adTypeText
    '设置编码的字符集
    .Charset = sCharset
    BByte2String = .ReadText
    .Close
End With
End Function
'
Function Suntime(ByVal lon As Single, ByVal lat As Single) As String
Dim Days&, X As Single, s(1)
Days = Date - DateSerial(Year(Date), 1, 0)
X = -Tan(-23.4 * Cos(8 * Atn(1) * (Days + 9) / 365) * Atn(1) / 45) * Tan(lat * Atn(1) / 45)
X = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
s(0) = 4 * (300 - lon - X * 45 / Atn(1))
s(1) = 8 * (300 - lon) - s(0)
Suntime = "日出时间为：" & Format(TimeSerial(0, s(0), 0), "hh:MM") & ",日落时间为：" & Format(TimeSerial(0, s(1), 0), "hh:MM")
End Function

[此贴子已经被作者于2022-12-17 16:33编辑过]
#13
yuma2022-12-18 08:37
回复 12楼 felix301
还可以，我主要用来算高德地图上收藏点的日出日落时间，方便出行。
#14
yuma2023-02-07 11:28
回复 4楼 mrexcel
计算这个日出日落时间，居然和一楼的程序得到的结果不一样。

Debug.Print Suntime(87.58512, 43.780072)      '格式：经度,纬度

为啥？
1
©2025, BC-CN.NET
电脑版