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编辑过]
2022-12-15 13:02
