前言.
[如果使用过程有什么问题可以QQ或邮箱联系我。 1919988942 | w2638301509@gmail.com]
______________________________________________
这大概是我做的最累的VB6作品，啊...累死了.....。
[并且我也懒得花心思去改代码了,里面有非常非常多的垃圾代码,但是对VB新手初学者而言,这个类模块非常适合你学习。因为简单且易懂]
第一次玩编程熬到四点.....感觉整个人都不好了。
类模块所有的气象数据都来源于中国气象网的各个平台,{手机微信PC和其他一些挖到的接口},定位服务,逆地址解析服务等来源于腾讯地图的WebAPI。
先上一下使用类模块的实例截图
代码如下：
'部分示例
Private Sub Command1_Click()
Dim i As 小林的天气模块
Set i = New 小林的天气模块
'i.Set_ID (i.Get_ID_forRegion("吉林", "磐石"))
'Call i.Refresh(, i.Get_ID_forRegion("吉林", "磐石"))
'23.3175479108, 116.3527464867
'Call i.Refresh("map", , 43.8504363962, 126.5322875977)
'MsgBox i.Get_生活指数(生活助手.l_穿衣指数)
Dim IP$, ID$, city$
city = i.Get_IP_forCity(IP, ID) '从本地IP中获取地点名称和地点编号
Dim lat#, lon#
Call i.Get_lat_lon_forIP(IP, lat, lon) '从IP中获取地点的经纬度
MsgBox "获取到的市名/地点名 :" & city
MsgBox "获取到的IP：" & IP
MsgBox "获取到的ID：" & ID
MsgBox "腾讯地图返回的经度:" & lon
MsgBox "腾讯地图返回的纬度:" & lat
MsgBox i.Get_map_for_lat_lon(lat, lon) '从经纬度获取地理位置地址
MsgBox "降水播报:" & vbCrLf & city & vbCrLf & i.Get_precipitation(lat, lon) '从经纬度获取该位置的降雨预报
Call i.Refresh(, ID) '从地点编号获取地点的气象情况
'{[Refresh 参数如下：
'[Mode : -ID/-经纬度 - 默认使用ID|传任意参数即使用经纬度]
'[ID ： 可空,但如果经纬度也空的话,会通过Debug返回Refresh错误/。]
'[纬度] ： 可空，但如果ID或者经度也空的话，会通过Debug返回Refresh错误/。]
'[经度] ： 可空，但如果ID或者纬度也空的话，会通过Debug返回Refresh错误/。]
'功能:翻译经纬度为ID，使用ID得到气象数据
']}
MsgBox i.Get_生活指数(l_穿衣指数) '获取生活指数 参数见生活助手枚举列表
End Sub
Private Sub Command2_Click()
'经纬度获取示例 ' [传参时 统一以纬度为先]
Dim lat#, lon# '定义经纬度
Dim i As 小林的天气模块
Set i = New 小林的天气模块
'从具体地址获取经纬度
MsgBox i.Get_Addr_for_lat_lon("广东省深圳市南山区南海大道3688号", lat, lon)
MsgBox "腾讯地图返回的经度:" & lon
MsgBox "腾讯地图返回的纬度:" & lat
'从本机IP地址获取经纬度
Dim IP$ '定义IP
'获取本机IP [v4]
Call i.Get_IP_forCity(IP)
MsgBox i.Get_lat_lon_forIP(IP, lat, lon)
MsgBox "腾讯地图返回的经度:" & lon
MsgBox "腾讯地图返回的纬度:" & lat
End Sub
Private Sub Command4_Click()
Dim i As 小林的天气模块
Set i = New 小林的天气模块
'国外ID[地点编号]获取方式：
'暂无 | 这个模块暂时没有办法获取国外天气 /。ps:因为我没有去找国外天气的接口
'_______________________________________________
'国内ID获取方式:
'1. '字典查询ID [只能查询到第三级 ] ：
'Get_ID_forRegion '从本地文件中查找编号 [省份,市名]
'带特别行政区名的级地域名必须声明国家！[],例如 :
MsgBox i.Get_ID_forRegion("中国香港", "中国香港", "新界")
MsgBox i.Get_ID_forRegion("中国澳门", "中国澳门", "氹仔岛")
MsgBox i.Get_ID_forRegion("中国台湾", "台北", "新竹")
'假设你要找直辖市,或城市的ID,直接填入前两级的参数即可
MsgBox i.Get_ID_forRegion("中国香港", "中国香港")
MsgBox i.Get_ID_forRegion("新疆", "克拉玛依")
MsgBox i.Get_ID_forRegion("广东", "深圳")
'2. 经纬度查询ID [精确到四级行政区 - 乡镇街道]
'Get_ID_for_lat_lon --- [纬度,经度]
'MsgBox i.Get_ID_for_lat_lon(44.166291, 80.468755)
'3. 二/三级的ID,和它的下级，三级/四级的地名，查询三级四级的ID [下面这个函数将返回茶山镇的ID]
MsgBox i.Get_ID_for_SubOrdinate(i.Get_ID_forRegion("广东", "东莞"), "茶山镇")
'___________________________________________
'使用示例：
i.Refresh 1, , 44.166291, 80.468755 '刷新信息 你可以设置定时器来保持最新的天气信息
MsgBox i.Get_天气信息(l_cityname)
MsgBox i.Get_天气信息(l_sfl)
MsgBox i.Get_生活指数(l_穿衣指数)
End Sub
Private Sub Command6_Click()
Call test
End Sub
Private Sub Form_Load()
Call test
End Sub
Sub test()
Command6.Enabled = False
Dim i As 小林的天气模块
Set i = New 小林的天气模块
List1.Clear
Dim IP$, ID$, city$, lat#, lon#
city = i.Get_IP_forCity(IP, ID)
Call i.Get_lat_lon_forIP(IP, lat, lon)
Label1.Caption = i.Get_map_for_lat_lon(lat, lon)
Label2.Caption = "降水播报:" & i.Get_precipitation(lat, lon) '从经纬度获取该位置的降雨预报
Call i.Refresh("随便什么都好啦", , lat, lon)
Label3.Caption = " 白天气温" & i.Get_天气信息(l_tem1) & " 夜间气温" & i.Get_天气信息(l_tem2) & " 天气状态 : " & i.Get_天气信息(l_weatherstate)
Label4.Caption = " 实时湿度：" & i.Get_天气信息(l_sd) & " 实时气温" & i.Get_天气信息(l_temnow) & " 实时风况:" & i.Get_天气信息(l_sfl) & " 实时气压：" & i.Get_天气信息(l_qy) & " 实时能见度：" & i.Get_天气信息(l_njd)
Label4.Caption = Label4.Caption & " 预报天气状态:" & i.Get_天气信息(l_tweatherstate) & " 气象更新时间: " & i.Get_天气信息(l_time)
Label5.Caption = i.Get_生活指数(l_约会指数)
Label6.Caption = "天气预警信息： " & i.Get_天气信息(l_warning_Caption)
Dim k%, kk%, sc12$()
'加入二十四消失天气预报
For k = 1 To 24
List1.AddItem "_____小林的分割线___________"
Call i.Get_十二时辰(i.Get_十二时辰_日期(k), sc12) '提示：一个时辰=两个小时
For kk = 0 To UBound(sc12)
List1.AddItem sc12(kk)
Next
Next
Command6.Enabled = True
End Sub
——————————————————————————————————————
类模块里每一个函数我都有注释,所以我就不多说了。
[工程打包文件在底部.]
——————————————————————————————————————
模块代码：
'——————————————————'小林的天气模块'—————————————————'
'行数统计：
'Form1.frm:135,Module1.bas:326,clsCookie.cls:95,clsSHttp.cls:129,小林的天气模块.cls:1643 总计 2328
' 数据来自'中国气象网'的多个平台 微信站,预报页,调用的JSON接口等
' By 风陵01 blog [主题还没改好]: https://www.cnblogs.com/lingqingxue/
'
' 具体的示例见Form1
'_________________________________________________________________________
' QQ:1919988942 E-mail : 1919988942@qq.com / w2638301509@gmail.com
'____________________________________________________
'——————————————————————————————————————————————————————————————————————————————————————————————————————————————————
'__________________设计出发是随时Copy随时能用的,所以没能{[根本不在乎]}满足高内聚低耦合的需求,如果看着不爽，你来改咯。
'完成了所有的接口 8.17 23：00
'解决24小时气象
'解决经纬度查询中
'生活助手,ID查询的所有信息基本完成
'接口基本找完了
'______________________________________________________________
'好的...写了半个框架，三个小时，一个调试，IDE崩溃退出
'我的天，真的TM，噩梦！为什么我不保存？ 可能太久没写VB6忘记被IDE支配的恐惧了
'好的我仔细思考一下，冷静一下吧！
'可能是上帝看不惯我的辣鸡代码,挥手....
'八点四十分，懒得继续写气象网接口的了，直接爬网页好了... | 记得保存！
' YY菌给出了个主意 工具 选项 启动程序时 提示保存改变
'网页效率不高，算了，回来继续找接口
'最后24小时还是在网页里找...郁闷，不过除了24时以外还挖到了其他的东西
'_________________________________________
Option Explicit
'——————————————————————————————————自定义
'-----------------------------
Public Enum life_Num
l_data = 0
l_空调开启指数
l_过敏指数
l_晨练指数
l_舒适度指数
l_穿衣指数
l_钓鱼指数
l_防晒指数
l_逛街指数
l_太阳镜指数
l_感冒指数
l_划船指数
l_交通指数
l_路况指数
l_晾晒指数
l_美发指数
l_夜生活指数
l_啤酒指数
l_放风筝指数
l_空气污染扩散条件指数
l_化妆指数
l_旅游指数
l_紫外线强度指数
l_风寒指数
l_洗车指数
l_心情指数
l_运动指数
l_约会指数
l_雨伞指数
l_中暑指数
End Enum
'__________________________________
Private Type 生活助手
l_data As String
l_空调开启指数 As String
l_过敏指数 As String
l_晨练指数 As String
l_舒适度指数 As String
l_穿衣指数 As String
l_钓鱼指数 As String
l_防晒指数 As String
l_逛街指数 As String
l_太阳镜指数 As String
l_感冒指数 As String
l_划船指数 As String
l_交通指数 As String
l_路况指数 As String
l_晾晒指数 As String
l_美发指数 As String
l_夜生活指数 As String
l_啤酒指数 As String
l_放风筝指数 As String
l_空气污染扩散条件指数 As String
l_化妆指数 As String
l_旅游指数 As String
l_紫外线强度指数 As String
l_风寒指数 As String
l_洗车指数 As String
l_心情指数 As String
l_运动指数 As String
l_约会指数 As String
l_雨伞指数 As String
l_中暑指数 As String
End Type
'__________________________________
Private Type 气象信息
'-----------------------------
l_cityname As String '地域名 ------ "延边新兴工业集中区
l_cityid As String '地域ID ------ "101060301011,,"
'-----------------------------
l_weatherstate As String '实时天气状态 ------ : l_weatherstate : "阴" : String : 小林的天气模块
l_weathere As String '英文标识 ------ : l_weathere : "Overcast" : String : 小林的天气模块
l_tweatherstate As String '预测天气状态 ------ : l_tweatherstate : "中雨转多云" : String : 小林的天气模块
l_time As String '信息更新时间 ------ : l_time : "14:40" : String : 小林的天气模块
l_data As String '今日日期 ------ : l_data : "08月16日|星期五|," : String : 小林的天气模块
'-----------------------------
l_tem1 As String '预报的白天气温 ------ : l_tem1 : "18℃" : String : 小林的天气模块
l_tem2 As String '预报的夜间气温 ------ : l_tem2 : "22℃" : String : 小林的天气模块
l_temnow As String '实时气温 as String' 摄氏度 ------ : l_temnow : "23" : String : 小林的天气模块
l_temfnow As String '实时气温 as String' 华氏度 ------ : l_temfnow : "73℉" : String : 小林的天气模块
'-----------------------------
l_tsd As String ' 今日{预测}相对湿度 [废弃] ------
'-----------------------------
l_tfl As String ' 预测风力状态 ------: l_tfl : "<3级西北风转西风" : String : 小林的天气模块
l_sfl As String '实时风力状态 ------: l_sfl : "西风1级" : String : 小林的天气模块
l_wse As String '实时风速 ------ : l_wse : "12km/h" : String : 小林的天气模块
'-----------------------------
'信息对接的是：http://wx.weather.com.cn as String'乡镇级地点使用县级行政区的信息
l_qy As String '气压 ------ : l_qy : "961" : String : 小林的天气模块
l_njd As String '能见度 ------ : l_njd : "30km" : String : 小林的天气模块
l_rain As String '降雨量 ------ : l_rain : "0.0" : String : 小林的天气模块
l_sd As String '实时相对湿度 ------ : l_sd : "75%" : String : 小林的天气模块
'-----------------------------
l_weatherCode As String '气象代码 d--->n ------ : l_weatherCode : "d02" : String : 小林的天气模块
l_weathercoded As String '气象代码 d ------ : l_weathercoded : "07" : String : 小林的天气模块
l_weathercoden As String '气象代码 n ------ : l_weathercoden : "n07" : String : 小林的天气模块
'_____________________________
l_warning_Province As String '预警的省份 ------ : l_warning_Province : "吉林省" : String : 小林的天气模块
l_warning_City As String '预警城市 ------ : l_warning_City : "延边朝鲜族自治州" : String : 小林的天气模块
l_warning_District As String '预警区域 ------ : l_warning_District : "延吉市" : String : 小林的天气模块
l_warning_ID As String '预警信号 ------ : l_warning_ID : "02" : String : 小林的天气模块
l_warning_Name As String '预警名 ------ : l_warning_Name : "暴雨" : String : 小林的天气模块
l_warning_Color_ID As String '预警信号级别颜色ID ------ : l_warning_Color_ID : "02" : String : 小林的天气模块
l_warning_Color_name As String '预警信号级别名 ------ : l_warning_Color_name : "黄色" : String : 小林的天气模块
l_warning_Time As String ' 预警更新时间 ------ : l_warning_Time : "201908152350" : String : 小林的天气模块
l_warning_Dinfo As String '预警的详细信息 ------ : l_warning_Dinfo : "延吉市气象局2019年8月15日23时50分发布暴雨黄色预警信号：目前我市部分地方已出现暴雨，预计未来12小时我市部分地方仍有20到50毫米降水，请有关部门及广大群众做好防范工作。（预警信息"
l_warning_Dinfo_ID As String '预警发布编号 ------ : l_warning_Dinfo_ID : "201908152350542922暴雨黄色" : String : 小林的天气模块
l_warning_Dinfo_url As String '预警发布地址 ------ : l_warning_Dinfo_url : "101060301201908152350000202.html" : String : 小林的天气模块
l_warning_Date As String '预警发布日期 ------ : l_warning_Date : "201908160000" : String : 小林的天气模块
l_warning_Caption As String '预警标题 ------ : l_warning_Caption : "吉林省延吉市发布暴雨黄色预警,," : String : 小林的天气模块
'-----------------------------
End Type
'__________________________________
Public Enum weather_info
'-----------------------------
l_cityname = 0 '地域名 ------ "延边新兴工业集中区
l_cityid '地域ID ------ "101060301011,,"
'-----------------------------
l_weatherstate '实时天气状态 ------ : l_weatherstate : "阴" : String : 小林的天气模块
l_weathere '英文标识 ------ : l_weathere : "Overcast" : String : 小林的天气模块
l_tweatherstate '预测天气状态 ------ : l_tweatherstate : "中雨转多云" : String : 小林的天气模块
l_time '信息更新时间 ------ : l_time : "14:40" : String : 小林的天气模块
l_data '今日日期 ------ : l_data : "08月16日|星期五|," : String : 小林的天气模块
'-----------------------------
l_tem1 '预报的白天气温] ------ : l_tem1 : "18℃" : String : 小林的天气模块
l_tem2 '预报的夜间气温 ------ : l_tem2 : "22℃" : String : 小林的天气模块
l_temnow '实时气温 ' 摄氏度 ------ : l_temnow : "23" : String : 小林的天气模块
l_temfnow '实时气温 ' 华氏度 ------ : l_temfnow : "73℉" : String : 小林的天气模块
'-----------------------------
l_tsd ' 今日{预测}相对湿度 [废弃] ------
'-----------------------------
l_tfl ' 预测风力状态 ------: l_tfl : "<3级西北风转西风" : String : 小林的天气模块
l_sfl '实时风力状态 ------: l_sfl : "西风1级" : String : 小林的天气模块
l_wse '实时风速 ------ : l_wse : "12km/h" : String : 小林的天气模块
'-----------------------------
'信息对接的是：http://wx.weather.com.cn '乡镇级地点使用县级行政区的信息
l_qy '气压 ------ : l_qy : "961" : String : 小林的天气模块
l_njd '能见度 ------ : l_njd : "30km" : String : 小林的天气模块
l_rain '降雨量 ------ : l_rain : "0.0" : String : 小林的天气模块
l_sd '实时相对湿度 ------ : l_sd : "75%" : String : 小林的天气模块
'-----------------------------
l_weatherCode '气象代码 d--->n ------ : l_weatherCode : "d02" : String : 小林的天气模块
l_weathercoded '气象代码 d ------ : l_weathercoded : "07" : String : 小林的天气模块
l_weathercoden '气象代码 n ------ : l_weathercoden : "n07" : String : 小林的天气模块
'_____________________________
l_warning_Province '预警的省份 ------ : l_warning_Province : "吉林省" : String : 小林的天气模块
l_warning_City '预警城市 ------ : l_warning_City : "延边朝鲜族自治州" : String : 小林的天气模块
l_warning_District '预警区域 ------ : l_warning_District : "延吉市" : String : 小林的天气模块
l_warning_ID '预警信号 ------ : l_warning_ID : "02" : String : 小林的天气模块
l_warning_Name '预警名 ------ : l_warning_Name : "暴雨" : String : 小林的天气模块
l_warning_Color_ID '预警信号级别颜色ID ------ : l_warning_Color_ID : "02" : String : 小林的天气模块
l_warning_Color_name '预警信号级别名 ------ : l_warning_Color_name : "黄色" : String : 小林的天气模块
l_warning_Time ' 预警更新时间 ------ : l_warning_Time : "201908152350" : String : 小林的天气模块
l_warning_Dinfo '预警的详细信息 ------ : l_warning_Dinfo : "延吉市气象局2019年8月15日23时50分发布暴雨黄色预警信号：目前我市部分地方已出现暴雨，预计未来12小时我市部分地方仍有20到50毫米降水，请有关部门及广大群众做好防范工作。（预警信息"
l_warning_Dinfo_ID '预警发布编号 ------ : l_warning_Dinfo_ID : "201908152350542922暴雨黄色" : String : 小林的天气模块
l_warning_Dinfo_url '预警发布地址 ------ : l_warning_Dinfo_url : "101060301201908152350000202.html" : String : 小林的天气模块
l_warning_Date '预警发布日期 ------ : l_warning_Date : "201908160000" : String : 小林的天气模块
l_warning_Caption '预警标题 ------ : l_warning_Caption : "吉林省延吉市发布暴雨黄色预警,," : String : 小林的天气模块
'-----------------------------
End Enum
'-----------------------------
Private Enum l_Error
NotID = &H1A
NotRegion = &HB
NotVar = &HC
End Enum
'-----------------------------
'-----------------------------
Private Type 十二时辰
l_timenow As String '预测时间
l_temnow As String '预测气温
l_windstate As String '风力状态
l_weatherCode As String '天气编号
l_weather As String '天气
l_sd As String '湿度
End Type
'-----------------------------
'_____________私有类模块定义
Private head As New Dictionary '头1 get
Private head2 As New Dictionary '头2 post 貌似用不到了...
Private Region As New Dictionary '地图字典
'Private Json As New clsSJson 'Json
'_____________________________
Private l_1day(23) As 十二时辰 '今时起24个小时的气象属性
'-----------------------------
'-----------------------------
Private Page$ '页面源码
Private l_weather As 气象信息 '属性
Private cityDZ$(), dataSK$(), alrmDZ$() ' dataZS$
'目的地大概状态 '目的地精确的状态 '目的地天气预警情况 '目的地生活指数【归纳在l_生活助手中】
Private l_生活助手 As 生活助手 '生活指数
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'需要用到腾讯地图WebService API[获取地理位置] /{除此以外任何已知城市ID的都可直接调用。}
'请把下面的常量修改为你申请的腾讯地图Key
'CULBZ-7ARWV-IOPPM-U4DDV-WS5TS-6MFHD
'JZSBZ-3WNK6-SWISL-MZYW4-XAW75-TKBDY
'8/15,19：41:
'JZ开头的是我申请的个人APIKey，单日限制一万,但是我无意间发现了气象网的KEY,居然没有白名单限制！ 直接各种调用，而且不限次数！? 【我没测试的....能用就行了嘛】
'8/17
'添加 Get_QQkey ,发现e.weather调用的Key居然是显式的，直接写在JS里,为了防止它更新然后消失，使用 Get_QQkey 获取 key,将在类模块生成时调取
Private l_QQmap_key
Private Const l_备用的QQkey = "JZSBZ-3WNK6-SWISL-MZYW4-XAW75-TKBDYl" '备用Key
'★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
'___________________________________________________________
'花了半天时间找到能用的接口如下：
'http://d1.weather.com.cn/weather_index/ '支持精确到市区[cityDZ&datSK&fc&dataZS]
'http://d1.weather.com.cn/dingzhi/ [cityDZ '支持镇乡 但是没有详细指数]
'https://d1.weather.com.cn/wap_180h/ '我真是败给这家网站的前端了....
'https://d1.weather.com.cn/wap_40d/ '未来生活指数和7天预报
'[经纬度查询天气 返回cityDZ 精确到路段]
'GET https://forecast.weather.com.cn/town/api/v1/sk?lat=xx.xxxxxx&lng=xxx.xxxxxx HTTP/1.1 '
'获取天气广播【降雨信息】
'"https://d3.weather.com.cn/webgis_rain_new/webgis/minute?lat=" & CStr(lat) & "&lon=" & CStr(lon) & "&callback=_jsonpqxkcyogtfe", "UTF-8"
'获取IP地址 [返回IP var IP]
'http://wgeo.weather.com.cn/?ip
'/后面那些我懒得写在这了
'______________________________________________________________
'____________私有函数
'___________初始化
Private Sub Class_Initialize()
Set head = New Dictionary
Dic_Load App.Path & "\地区信息.txt" '载入地图
cityDZ_Load '载入City配置
dataSK_Load '载入dataSK配置
alrmDZ_Load '载入alrmDZ配置
l_QQmap_key = Get_qqkey '尝试寻找气象网的QQmap_key
End Sub
'___________返回气象状态
Private Function Get_WeatherState$(ID$)
Dim 气象编号 As Integer
Dim length%, c$(), i%: length = Len(ID)
If length = 3 Then ReDim c(1): c(0) = CInt(Mid(ID, 1, 1)): c(1) = CInt(Mid(ID, 2, 2))
If length = 4 Then ReDim c(1): c(0) = CInt(Mid(ID, 1, 2)): c(1) = CInt(Mid(ID, 3, 2))
If length = 2 Then ReDim c(1): c(0) = CInt(Mid(ID, 1, 1)): c(1) = CInt(Mid(ID, 2, 1))
If length = 1 Then ReDim c(0): c(0) = CInt(ID)
For i = 0 To UBound(c)
气象编号 = c(i)
Select Case 气象编号
Case 0
Get_WeatherState = "晴"
Case 1
Get_WeatherState = "多云"
Case 2
Get_WeatherState = "阴"
Case 3
Get_WeatherState = "阵雨"
Case 4
Get_WeatherState = "雷阵雨"
Case 5
Get_WeatherState = "雷阵雨伴有冰雹"
Case 6
Get_WeatherState = "雨夹雪"
Case 7
Get_WeatherState = "小雨"
Case 8
Get_WeatherState = "中雨"
Case 9
Get_WeatherState = "大雨"
Case 10
Get_WeatherState = "暴雨"
Case 11
Get_WeatherState = "大暴雨"
Case 12
Get_WeatherState = "特大暴雨"
Case 13
Get_WeatherState = "阵雪"
Case 14
Get_WeatherState = "小雪"
Case 15
Get_WeatherState = "中雪"
Case 16
Get_WeatherState = "大雪"
Case 17
Get_WeatherState = "暴雪"
Case 18
Get_WeatherState = "雾"
Case 19
Get_WeatherState = "冻雨"
Case 20
Get_WeatherState = "沙尘暴"
Case 21
Get_WeatherState = "小到中雨"
Case 22
Get_WeatherState = "中到大雨"
Case 23
Get_WeatherState = "大到暴雨"
Case 24
Get_WeatherState = "暴雨到大暴雨"
Case 25
Get_WeatherState = "大暴雨到特大暴雨"
Case 26
Get_WeatherState = "小到中雪"
Case 27
Get_WeatherState = "中到大雪"
Case 28
Get_WeatherState = "大到暴雪"
Case 29
Get_WeatherState = "浮尘"
Case 30
Get_WeatherState = "扬沙"
Case 31
Get_WeatherState = "强沙尘暴"
Case 53
Get_WeatherState = "霾"
Case 99
Get_WeatherState = "无"
Case 32
Get_WeatherState = "浓雾"
Case 49
Get_WeatherState = "强浓雾"
Case 54
Get_WeatherState = "中度霾"
Case 55
Get_WeatherState = "重度霾"
Case 56
Get_WeatherState = "严重霾"
Case 57
Get_WeatherState = "大雾"
Case 58
Get_WeatherState = "特强浓雾"
Case 301
Get_WeatherState = "雨"
Case 302
Get_WeatherState = "雪"
Case Else
Get_WeatherState = "查询天气失败."
End Select
If UBound(c) = 1 And i = 0 Then Get_WeatherState = Get_WeatherState & "转"
Next
End Function
'___________返回风力风向
Private Function Get_WindState$(ID$)
Dim 风向编号 As Integer
风向编号 = CInt(ID)
Select Case 风向编号
Case 0
Get_WindState = "无持续风向"
Case 1
Get_WindState = "东北风"
Case 2
Get_WindState = "东风"
Case 3
Get_WindState = "东南风"
Case 4
Get_WindState = "南风"
Case 5
Get_WindState = "西南风"
Case 6
Get_WindState = "西风"
Case 7
Get_WindState = "西北风"
Case 8
Get_WindState = "北风"
Case 9
Get_WindState = "旋转风"
End Select
End Function
Private Function Get_WinsState$(ID$)
Dim 风级编号 As Integer
风级编号 = CInt(ID)
Select Case 风级编号
Case 0
Get_WinsState = "<3级"
Case 1
Get_WinsState = "3-4级"
Case 2
Get_WinsState = "4-5级"
Case 3
Get_WinsState = "5-6级"
Case 4
Get_WinsState = "6-7级"
Case 5
Get_WinsState = "7-8级"
Case 6
Get_WinsState = "8-9级"
Case 7
Get_WinsState = "9-10级"
Case 8
Get_WinsState = "10-11级"
Case 9
Get_WinsState = "11-12级"
End Select
End Function
'___________加载地图字典
Private Sub Dic_Load(ByVal File$)
On Error GoTo 404
Dim s$
Open File For Input As #1
s = ByteToStr(InputB(LOF(1), #1), "UTF-8")
Close #1
Dim Dic_s$()
'读取内容到s
Dic_s = Split(s, vbCrLf)
'读取内容到字典
Dim i As Long
For i = 0 To UBound(Dic_s) Step 2
Region.Add Dic_s(i), Dic_s(i + 1)
Next
Exit Sub
404:
MsgBox "错误代码：" & l_Error.NotRegion
End
End Sub
'___________加载alrmDZK
Private Sub alrmDZ_Load()
ReDim alrmDZ$(12)
alrmDZ(0) = "alarmDZww1" '预警省份
alrmDZ(1) = "w2" '预警城市
alrmDZ(2) = "w3" '预警区域
alrmDZ(3) = "w4" '预警信号
alrmDZ(4) = "w5" '预警名
alrmDZ(5) = "w6" '预警信号级别颜色ID '例如蓝黄橙红
alrmDZ(6) = "w7" '预警信号级别名
alrmDZ(7) = "w8" ' 预警更新时间
alrmDZ(8) = "w9" '预警的详细信息 '例如XXX气象局于XXX升级某预警
alrmDZ(9) = "w10" '预警发布编号
alrmDZ(10) = "w11" '预警发布地址
alrmDZ(11) = "w12" '预警发布时间
alrmDZ(12) = "w13" '预警标题
End Sub
'___________加载dataSK
Private Sub dataSK_Load()
ReDim dataSK$(17)
dataSK(0) = "cityname" '地域名称
dataSK(1) = "tempf" '实时气温 华氏度
dataSK(2) = "WD" '风向
dataSK(3) = "WS" '风级
dataSK(4) = "wse" '风速
dataSK(5) = "SD" '相对湿度
dataSK(6) = "time" '更新时间
dataSK(7) = "qy" '气压
dataSK(8) = "njd" '能见度
dataSK(9) = "rain24h" '???24小时降水？放在这里过滤的时候才会自动排除掉____应该用不到所以没加在信息里
dataSK(10) = "date" '日期
dataSK(11) = "city" '地域代码
dataSK(12) = "temp" '实时气温 摄氏度
dataSK(13) = "weathercode" '气象代码
dataSK(14) = "rain" '降雨量
dataSK(15) = "weathere" '气象英文标识
dataSK(16) = "weather" '气象中文
End Sub
'___________加载City
Private Sub cityDZ_Load()
ReDim cityDZ$(9)
cityDZ(0) = "weathercoden" '这个是n的值 d-->n d转n
cityDZ(1) = "tempn" '最高温度
cityDZ(2) = "temp" '最低温度
cityDZ(3) = "cityname" '地名
cityDZ(4) = "ws" '当前风力
cityDZ(5) = "wd" '当前风级
cityDZ(6) = "fctime" '更新时间
cityDZ(7) = "weathercoded" '这个是d的值 d-->n d转n 例如 大雨转中雨
cityDZ(8) = "weather" '气象
cityDZ(9) = "city" '地域代码
End Sub
'___________加载dataZS
'Private Sub dataZS_Load()
'ReDim dataZS$(0)
'有点多.... 这里就不用参数名对应的办法了，
'取date数据之后就直接格式化之后的参数,只保留汉字和逗号
'通过逗号分类字段
'dateZS(0) = "data"
'End Sub
'___________________设置
Private Sub Set_cityDz_info(ByVal Value$)
Dim i%, c%
For i = 0 To UBound(cityDZ)
c = InStr(Value, cityDZ(i))
If c = 1 Then
Value = Mid(Value, c + Len(cityDZ(i)), Len(Value) - Len(cityDZ(i)))
Select Case i
Case 0
l_weather.l_weathercoden = Value
Case 1
l_weather.l_tem1 = Value
Case 2
l_weather.l_tem2 = Value
Case 3
l_weather.l_cityname = Value
Case 4
l_weather.l_tfl = l_weather.l_tfl & Value '级别
Case 5
l_weather.l_tfl = l_weather.l_tfl & Value '风向
Case 6
l_weather.l_time = Mid(Value, 1, 2) & ":" & Mid(Value, 3, 2)
Case 7
l_weather.l_weathercoded = Value
Case 8
l_weather.l_tweatherstate = Value
Case 9
l_weather.l_cityid = Value
End Select
Exit Sub
End If
Next
End Sub
'---------------处理乡镇的气象信息
'处理 var forecast_value_1h [二十四小时预报] var forecast_default[实时预报]
Private Function Set_foreCase_info(ByRef cast_value_1h$(), ByRef cast_default$())
Dim tmp_value_1h$, value_1h$()
Dim i%, ii%, Start%
'先处理二十四小时
Start = 1 '忽略掉变量名
For i = 0 To 23
l_1day(i).l_windstate = ""
tmp_value_1h = Set_foreCase_info_value_1h_list(cast_value_1h, Start)
value_1h = Split(tmp_value_1h, ",")
For ii = 0 To UBound(value_1h)
'l_1day - 十二时辰
Select Case ii
Case 0
l_1day(i).l_timenow = Mid(value_1h(ii), 5, 2)
Case 1
l_1day(i).l_weatherCode = Mid(value_1h(ii), Len("weathercode") + 1, Len(value_1h(ii)) - Len("weathercode"))
Case 2
l_1day(i).l_weather = Mid(value_1h(ii), Len("weather") + 1, Len(value_1h(ii)) - Len("weather"))
Case 3
l_1day(i).l_temnow = Mid(value_1h(ii), Len("temp") + 1, Len(value_1h(ii)) - Len("temp")) & "℃"
Case 4
l_1day(i).l_windstate = Mid(value_1h(ii), Len("windL") + 1, Len(value_1h(ii)) - Len("windL"))
Case 5
l_1day(i).l_windstate = Mid(value_1h(ii), Len("windD") + 1, Len(value_1h(ii)) - Len("windD")) & l_1day(i).l_windstate
End Select
Next
Next
'实时预报
Dim tmp_default$
For i = 1 To 8
Select Case i
Case 1
l_weather.l_time = Mid(cast_default(i), Len("time") + 1, Len(cast_default(i)) - Len("time"))
l_weather.l_time = Mid(l_weather.l_time, 1, 2) & ":" & Mid(l_weather.l_time, 3, 2)
Case 3
l_weather.l_temnow = Mid(cast_default(i), Len("temp") + 1, Len(cast_default(i)) - Len("temp")) & "℃"
End Select
Next
End Function
Private Function Set_foreCase_info_value_1h_list$(ByRef Value$(), ByRef Start%)
Dim i%
For i = Start To UBound(Value)
If Value(i) <> "" Then
Set_foreCase_info_value_1h_list = Set_foreCase_info_value_1h_list & Value(i) & ","
Else
Start = i + 2
Exit Function
End If
Next
End Function
'---------------处理气象信息
Private Sub Set_dataSK_info(ByVal Value$)
Dim i%, c%
For i = 0 To UBound(dataSK)
'验证参数
c = InStr(Value, dataSK(i))
If c = 1 Then
'获得参数
Value = Mid(Value, c + Len(dataSK(i)), Len(Value) - Len(dataSK(i)))
'设置气象属性
Select Case i
Case 0
l_weather.l_cityname = Value '地域名称
Case 1
l_weather.l_temfnow = Value & "℉" '实时气温 华氏度
Case 2
l_weather.l_sfl = Value '风向
Case 3
l_weather.l_sfl = l_weather.l_sfl & Value '加上风级
Case 4
l_weather.l_wse = Trim_wse(Value) & "km/h" '风速
Case 5
l_weather.l_sd = Value '湿度
Case 6
Value = Mid(Value, 1, 2) & ":" & Mid(Value, 3, 2)
l_weather.l_time = Value
Case 7
l_weather.l_qy = Value '气压
Case 8
l_weather.l_njd = Value '能见度
Case 9
Exit Sub
Case 10
l_weather.l_data = Value '日期
Case 11
l_weather.l_cityid = Value '地域代码
Case 12
l_weather.l_temnow = Value & "℃" '实时气温 摄氏度
Case 13
l_weather.l_weatherCode = Value
Case 14
l_weather.l_rain = Value '降雨量
Case 15
l_weather.l_weathere = Value '气象状态英文
Case 16
l_weather.l_weatherstate = Value '气象状态
End Select
Exit Sub
End If
Next
End Sub
Private Sub Set_hourdata(ByVal Value$)
Dim i%, s$(), ii%
s = Split(Value, ",")
For i = 0 To 143 Step 6
For ii = 0 To 5
Select Case ii
Case 0 'jc = 风级编号
l_1day(i / 6).l_windstate = Get_WinsState(Trim_Num(s(ii + i)))
Case 1 'jb = 气温
l_1day(i / 6).l_temnow = Trim_Num(s(ii + i)) & "℃"
Case 2 'je = 相对湿度
l_1day(i / 6).l_sd = Trim_Num(s(ii + i))
Case 3 'jd = '风向
l_1day(i / 6).l_windstate = l_1day(i / 6).l_windstate & Get_WindState(Trim_Num(s(ii + i)))
Case 4 'jf = '日期+小时
l_1day(i / 6).l_timenow = Trim_Num(s(ii + i))
Case 5 'ja = 天气现象编号
l_1day(i / 6).l_weatherCode = Trim_Num(s(ii + i))
l_1day(i / 6).l_weather = Get_WeatherState(l_1day(i / 6).l_weatherCode)
End Select
Next
Next
End Sub
Private Sub Set_alrmDz_info(ByVal Value$)
Dim i%, c%
Value = Trim_weather(Value)
For i = 0 To UBound(alrmDZ)
'验证参数
c = InStr(Value, alrmDZ(i))
If c = 1 Then
'获得参数
Value = Mid(Value, c + Len(alrmDZ(i)), Len(Value) - Len(alrmDZ(i)))
Select Case i
Case 0
l_weather.l_warning_Province = Value
Case 1
l_weather.l_warning_City = Value
Case 2
l_weather.l_warning_District = Value
Case 3
l_weather.l_warning_ID = Value
Case 4
l_weather.l_warning_Name = Value
Case 5
l_weather.l_warning_Color_ID = Value
Case 6
l_weather.l_warning_Color_name = Value
Case 7
l_weather.l_warning_Time = Value
Case 8
l_weather.l_warning_Dinfo = Value
Case 9
l_weather.l_warning_Dinfo_ID = Value
Case 10
l_weather.l_warning_Dinfo_url = Value
Case 11
l_weather.l_warning_Date = Value
Case 12
l_weather.l_warning_Caption = Value
End Select
Exit Sub
End If
Next
End Sub
Private Sub Set_dataZs_info(ByRef Value$())
Const length As Integer = 3
Dim Line_s$, i%
Call Trim_chinese(Value) '去英文和各种特殊符号
For i = 0 To UBound(Value) Step length
Select Case i
Case 0
l_生活助手.l_data = Value(i)
Case 1 * length
l_生活助手.l_空调开启指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 2 * length
l_生活助手.l_过敏指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 3 * length
l_生活助手.l_晨练指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 4 * length
l_生活助手.l_舒适度指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 5 * length
l_生活助手.l_穿衣指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 6 * length
l_生活助手.l_钓鱼指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 7 * length
l_生活助手.l_防晒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 8 * length
l_生活助手.l_逛街指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 9 * length
l_生活助手.l_太阳镜指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 10 * length
l_生活助手.l_感冒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 11 * length
l_生活助手.l_划船指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 12 * length
l_生活助手.l_交通指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 13 * length
l_生活助手.l_路况指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 14 * length
l_生活助手.l_晾晒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 15 * length
l_生活助手.l_美发指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 16 * length
l_生活助手.l_夜生活指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 17 * length
l_生活助手.l_啤酒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 18 * length
l_生活助手.l_放风筝指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 19 * length
l_生活助手.l_空气污染扩散条件指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 20 * length
l_生活助手.l_化妆指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 21 * length
l_生活助手.l_旅游指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 22 * length
l_生活助手.l_紫外线强度指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 23 * length
l_生活助手.l_风寒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 24 * length
l_生活助手.l_洗车指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 25 * length
l_生活助手.l_心情指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 26 * length
l_生活助手.l_运动指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 27 * length
l_生活助手.l_约会指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 28 * length
l_生活助手.l_雨伞指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
Case 29 * length
l_生活助手.l_中暑指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)
End Select
Next
End Sub
'——————————从返回信息中提取经纬度
Private Sub Trim_jwd(ByVal Value$, ByRef lat#, ByRef lon#)
Dim status$
Value = Trim_weather(Value)
status = Mid(Value, InStr(Value, "status") + 6, InStr(Value, "message") - InStr(Value, "status") - 6)
If status = "0" Then
Debug.Print Value
lat = CDbl(Mid(Value, InStr(Value, "lat") + 3, InStr(Value, "lng") - InStr(Value, "lat") - 3))
lon = CDbl(Mid(Value, InStr(Value, "lng") + 3, InStr(Value, "adinfo") - InStr(Value, "lng") - 3))
End If
End Sub
'——————————从返回信息中提取经纬度 [先取lon 后去lat]
Private Sub Trim_jwdB(ByVal Value$, ByRef lat#, ByRef lon#)
Dim status$
Value = Trim_weather(Value)
status = Mid(Value, InStr(Value, "status") + 6, InStr(Value, "message") - InStr(Value, "status") - 6)
If status = "0" Then
Debug.Print Value
lon = CDbl(Mid(Value, InStr(Value, "lng") + 3, InStr(Value, "lat") - InStr(Value, "lng") - 3))
lat = CDbl(Mid(Value, InStr(Value, "lat") + 3, InStr(Value, "adinfo") - InStr(Value, "lat") - 3))
End If
End Sub
'——————————从经纬度解析中提取地址
Private Sub Trim_Addr(ByRef Value$, ByRef lat#, ByRef lon#)
Dim status$
Value = Trim_weather(Value)
status = Mid(Value, InStr(Value, "status") + 6, InStr(Value, "message") - InStr(Value, "status") - 6)
If status = "0" Then
Dim address$, recommend$
'取address值
address = Mid(Value, InStr(Value, "address") + 7, InStr(Value, "formattedaddresses") - InStr(Value, "address") - 7)
recommend = Mid(Value, InStr(Value, "recommend") + 9, InStr(Value, "rough") - InStr(Value, "recommend") - 9)
Value = "坐标地址：" & address & vbCrLf & "地名:" & recommend
End If
End Sub
'___________去除多余的格式
Private Function Trim_weather$(ByVal ss$)
Dim i As Integer, j As Integer, St As String, St1 As String
Dim SSnew$
i = Len(ss)
For j = 1 To i
St = Mid(ss, j, 1)
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "0" And St1 <= "9" Or _
St1 = "℃" Or St1 = "/" Or St1 = "<" Or St1 = ">" And Asc(St1) > 255 Or _
Asc(St1) < 0 Or St1 = "." Or St1 = "%" Or St1 = "(" Or St1 = ")" Or St1 = "{" Or St1 = "}" Then
If St1 = "(" Or St1 = ")" Then
St = "|"
End If
If St1 = "{" Or St1 = "}" Then
St = ","
End If
Trim_weather = Trim_weather & St
End If
Next
End Function
'___________去除多余的格式
Private Function Trim_weatherB$(ByVal ss$)
Dim i As Integer, j As Integer, St As String, St1 As String
Dim SSnew$
i = Len(ss)
For j = 1 To i
St = Mid(ss, j, 1)
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "0" And St1 <= "9" Or _
St1 = "℃" Or St1 = "/" Or St1 = "<" Or St1 = ">" And Asc(St1) > 255 Or _
Asc(St1) < 0 Or St1 = "." Or St1 = "%" Or St1 = "(" Or St1 = ")" Or St1 = "{" Or St1 = "}" Or St1 = "," Then
If St1 = "," Then
St = ","
End If
If St1 = "{" Then
St = ","
End If
If St1 = "}" Then
St = ","
End If
Trim_weatherB = Trim_weatherB & St
End If
Next
End Function
'___________去除多余的格式
Private Function Trim_weatherC$(ByVal ss$)
Dim i As Long, j As Long, St As String, St1 As String '调整为long防止溢出
Dim SSnew$
i = Len(ss)
For j = 1 To i
St = Mid(ss, j, 1)
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "0" And St1 <= "9" Or _
St1 = "℃" Or St1 = "/" And Asc(St1) > 255 Or _
Asc(St1) < 0 Or St1 = "," Or St1 = ":" Then
Trim_weatherC = Trim_weatherC & St
End If
Next
End Function
Private Function Trim_weatherD$(ByVal ss$)
Dim i As Long, j As Long, St As String, St1 As String '调整为long防止溢出
Dim SSnew$
i = Len(ss)
For j = 1 To i
St = Mid(ss, j, 1)
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "0" And St1 <= "9" Or _
St1 = "℃" Or St1 = "/" And Asc(St1) > 255 Or _
Asc(St1) < 0 Or St1 = "," Or St1 = ":" Or St1 = "-" Then
Trim_weatherD = Trim_weatherD & St
End If
Next
End Function
'————————------只保留数字
Private Function Trim_Num(ByVal ss$)
Dim i As Integer, s As String, St1$
Trim_Num = ""
For i = 1 To Len(ss)
s = Mid(ss, i, 1)
St1 = UCase(s)
If St1 >= "0" And St1 <= "9" Then
Trim_Num = Trim_Num & s
End If
Next
Trim_Num = Trim(Trim_Num)
End Function
'___________只保留汉字和“,”
Private Sub Trim_chinese(ss() As String)
Dim i As Integer, j As Integer, St As String, St1 As String, c%
Dim e$
For c = 0 To UBound(ss)
e = ""
i = Len(ss(c))
For j = 1 To i
St = Mid(ss(c), j, 1)
St1 = UCase(St)
If Asc(St1) > 255 Or Asc(St1) < 0 Or St1 = "," Or St1 >= "0" And St1 <= "9" Then
e = e & St
End If
Next
ss(c) = e
Next
End Sub
'___________过滤AC
Private Sub Trim_Ac(ss() As String)
Dim i As Integer, j As Integer, St As String, St1 As String, c%
Dim e$
For c = 0 To UBound(ss)
e = ""
i = Len(ss(c))
For j = 1 To i
St = Mid(ss(c), j, 1)
St1 = Asc(St)
If St1 <> Asc("a") And St1 <> Asc("c") And St1 <> Asc("n") And St1 <> Asc("x") And St1 <> Asc("z") Then
If St1 = Asc(",") Then
St = ""
End If
e = e & St
End If
Next
ss(c) = e
Next
End Sub
'_____________过滤中文
Private Function Trim_ABCD$(ByVal Value$)
Dim i As Integer, s As String
Trim_ABCD = ""
For i = 1 To Len(Value)
s = Mid(Value, i, 1)
If (Asc(s) > 255 Or Asc(s) > 0) Then Trim_ABCD = Trim_ABCD & s
Next
Trim_ABCD = Trim(Trim_ABCD)
End Function
'___________过滤掉残留的JS转移字符
Private Function Trim_wse$(ByVal Value$)
Dim i As Integer, s As String
For i = 1 To Len(Value)
s = Mid(Value, i, 1)
If (s >= "0" And s <= "9") Or s = "." Then Trim_wse = Trim_wse & s
Next
End Function
'______________假重置
Private Function Restation_false()
If l_weather.l_cityname = "" Then l_weather.l_cityname = "暂无"
If l_weather.l_cityid = "" Then l_weather.l_cityid = "暂无"
If l_weather.l_weatherstate = "" Then l_weather.l_weatherstate = "暂无"
If l_weather.l_weathere = "" Then l_weather.l_weathere = "暂无"
If l_weather.l_tweatherstate = "" Then l_weather.l_tweatherstate = "暂无"
If l_weather.l_time = "" Then l_weather.l_time = "暂无"
If l_weather.l_data = "" Then l_weather.l_data = "暂无"
If l_weather.l_tem1 = "" Then l_weather.l_tem1 = "暂无"
If l_weather.l_tem2 = "" Then l_weather.l_tem2 = "暂无"
If l_weather.l_temnow = "" Then l_weather.l_temnow = "暂无"
If l_weather.l_temfnow = "" Then l_weather.l_temfnow = "暂无"
If l_weather.l_tsd = "" Then l_weather.l_tsd = "暂无"
If l_weather.l_tfl = "" Then l_weather.l_tfl = "暂无"
If l_weather.l_sfl = "" Then l_weather.l_sfl = "暂无"
If l_weather.l_wse = "" Then l_weather.l_wse = "暂无"
If l_weather.l_qy = "" Then l_weather.l_qy = "暂无"
If l_weather.l_njd = "" Then l_weather.l_njd = "暂无"
If l_weather.l_rain = "" Then l_weather.l_rain = "暂无"
If l_weather.l_sd = "" Then l_weather.l_sd = "暂无"
If l_weather.l_weatherCode = "" Then l_weather.l_weatherCode = "暂无"
If l_weather.l_weathercoded = "" Then l_weather.l_weathercoded = "暂无"
If l_weather.l_weathercoden = "" Then l_weather.l_weathercoden = "暂无"
If l_weather.l_warning_Province = "" Then l_weather.l_warning_Province = "暂无"
If l_weather.l_warning_City = "" Then l_weather.l_warning_City = "暂无"
If l_weather.l_warning_District = "" Then l_weather.l_warning_District = "暂无"
If l_weather.l_warning_ID = "" Then l_weather.l_warning_ID = "暂无"
If l_weather.l_warning_Name = "" Then l_weather.l_warning_Name = "暂无"
If l_weather.l_warning_Color_ID = "" Then l_weather.l_warning_Color_ID = "暂无"
If l_weather.l_warning_Color_name = "" Then l_weather.l_warning_Color_name = "暂无"
If l_weather.l_warning_Time = "" Then l_weather.l_warning_Time = "暂无"
If l_weather.l_warning_Dinfo = "" Then l_weather.l_warning_Dinfo = "暂无"
If l_weather.l_warning_Dinfo_ID = "" Then l_weather.l_warning_Dinfo_ID = "暂无"
If l_weather.l_warning_Dinfo_url = "" Then l_weather.l_warning_Dinfo_url = "暂无"
If l_weather.l_warning_Date = "" Then l_weather.l_warning_Date = "暂无"
If l_weather.l_warning_Caption = "" Then l_weather.l_warning_Caption = "暂无"
Dim i%
For i = 0 To 23
If l_1day(i).l_sd = "" Then l_1day(i).l_sd = "暂无"
If l_1day(i).l_temnow = "" Then l_1day(i).l_temnow = "暂无"
If l_1day(i).l_timenow = "" Then l_1day(i).l_timenow = "暂无"
If l_1day(i).l_weather = "" Then l_1day(i).l_weather = "暂无"
If l_1day(i).l_weatherCode = "" Then l_1day(i).l_weatherCode = "暂无"
If l_1day(i).l_windstate = "" Then l_1day(i).l_windstate = "暂无"
Next
End Function
'______________重置
Private Function Restation()
l_weather.l_cityname = "暂无"
l_weather.l_cityid = "暂无"
l_weather.l_weatherstate = "暂无"
l_weather.l_weathere = "暂无"
l_weather.l_tweatherstate = "暂无"
l_weather.l_time = "暂无"
l_weather.l_data = "暂无"
l_weather.l_tem1 = "暂无"
l_weather.l_tem2 = "暂无"
l_weather.l_temnow = "暂无"
l_weather.l_temfnow = "暂无"
l_weather.l_tsd = "暂无"
l_weather.l_tfl = "暂无"
l_weather.l_sfl = "暂无"
l_weather.l_wse = "暂无"
l_weather.l_qy = "暂无"
l_weather.l_njd = "暂无"
l_weather.l_rain = "暂无"
l_weather.l_sd = "暂无"
l_weather.l_weatherCode = "暂无"
l_weather.l_weathercoded = "暂无"
l_weather.l_weathercoden = "暂无"
l_weather.l_warning_Province = "暂无"
l_weather.l_warning_City = "暂无"
l_weather.l_warning_District = "暂无"
l_weather.l_warning_ID = "暂无"
l_weather.l_warning_Name = "暂无"
l_weather.l_warning_Color_ID = "暂无"
l_weather.l_warning_Color_name = "暂无"
l_weather.l_warning_Time = "暂无"
l_weather.l_warning_Dinfo = "暂无"
l_weather.l_warning_Dinfo_ID = "暂无"
l_weather.l_warning_Dinfo_url = "暂无"
l_weather.l_warning_Date = "暂无"
l_weather.l_warning_Caption = "暂无"
Dim i%
For i = 0 To 23
l_1day(i).l_sd = "暂无"
l_1day(i).l_temnow = "暂无"
l_1day(i).l_timenow = "暂无"
l_1day(i).l_weather = "暂无"
l_1day(i).l_weatherCode = "暂无"
l_1day(i).l_windstate = "暂无"
Next
End Function
'——————————————————————————————————————————————————————————————公有区域
Public Sub Get_十二时辰(ByVal data$, ByRef OutValue$())
Dim tmp$, i%
ReDim OutValue(4)
For i = 0 To UBound(l_1day)
If l_1day(i).l_timenow = data Then
OutValue(0) = "预报时间： " & l_1day(i).l_timenow
OutValue(1) = "预测当时气温： " & l_1day(i).l_temnow
OutValue(2) = "预测当时风向风力 " & l_1day(i).l_windstate
OutValue(3) = "预测当时相对湿度： " & l_1day(i).l_sd
OutValue(4) = "预测当时天气情况： " & l_1day(i).l_weather
Exit Sub
End If
Next
End Sub
'返回十二时辰列表的日期
Public Function Get_十二时辰_日期$(ByVal Value%)
If Value <= 24 And Value >= 1 Then
Get_十二时辰_日期 = l_1day(Value - 1).l_timenow
End If
End Function
'---------------获取乡镇的气象信息
'处理网页 var forecast_value_1h [二十四小时预报] var forecast_default[实时预报]
'http://forecast.weather.com.cn/town/weather1dn/101280502004.shtml
Public Sub Get_foreCase_info(ByRef fore_cast_value_1h$(), ByRef fore_cast_default$(), ByVal PageID$)
Dim http As New clsSHttp
Line1:
DoEvents
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Host", "forecast.weather.com.cn"
head.Add "Connection", "keep-alive"
head.Add "Sec-Fetch-Mode", "cors"
'_________________________________________
Set http.RequestHeader = head
Dim url$
url = "http://forecast.weather.com.cn/town/weather1dn/" & PageID & ".shtml"
http.SetInfo url, "Utf-8"
Dim tmp$
tmp = http.Get_RetString
Dim count%
If tmp = "" Then
If PageID = "失败" Or PageID = "" Then: Debug.Print "Get_foreCase_info$ : 参数PageID异常 值: " & PageID: Exit Sub
If count < 3 Then
count = count + 1
Debug.Print "重新发送请求...第" & count & "次"
GoTo Line1
Else
Exit Sub
End If
End If
Debug.Print tmp
tmp = Mid(tmp, InStr(tmp, "var forecast_1h"), InStr(tmp, "<!--顶部模块TOP-->") - InStr(tmp, "var forecast_1h"))
Dim tmpB$(), i%, ii%:
tmpB = Split(tmp, "var")
'返回元素
tmpB(1) = Trim_weatherB(tmpB(1)): fore_cast_value_1h = Split(tmpB(1), ","): fore_cast_default = Split(Trim_weatherB(tmpB(2)), ",")
End Sub
Public Function Get_qqkey$()
'返回e.weather 默认加载显示Key
Dim http As New clsSHttp, url$
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Upgrade-Insecure-Requests", "1"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
url = "http://e.weather.com.cn"
'________________________________________
Set http.RequestHeader = head
http.SetInfo url, "UTF-8"
Line1:
Dim temp$, count%
temp = Trim_weatherD(http.Get_RetString)
If temp = "" Then
If count >= 3 Then
GoTo Line2
End If
count = count + 1
GoTo Line1
End If
Get_qqkey = Mid(temp, InStr(temp, "vargeolocationnewqqmapsGeolocation") + Len("vargeolocationnewqqmapsGeolocation"), InStr(temp, ",jsybdocumentgetElementBy") - InStr(temp, "vargeolocationnewqqmapsGeolocation") - Len("vargeolocationnewqqmapsGeolocation"))
Line2:
If Get_qqkey = "" Then
MsgBox "获取气象网使用的腾讯地图——key失败,将启用备用Key."
Get_qqkey = l_备用的QQkey
End If
End Function
Public Function Get_生活指数$(ByVal Value As life_Num)
Select Case Value
Case 0
Get_生活指数 = l_生活助手.l_data
Case 1
Get_生活指数 = l_生活助手.l_空调开启指数
Case 2
Get_生活指数 = l_生活助手.l_过敏指数
Case 3
Get_生活指数 = l_生活助手.l_晨练指数
Case 4
Get_生活指数 = l_生活助手.l_舒适度指数
Case 5
Get_生活指数 = l_生活助手.l_穿衣指数
Case 6
Get_生活指数 = l_生活助手.l_钓鱼指数
Case 7
Get_生活指数 = l_生活助手.l_防晒指数
Case 8
Get_生活指数 = l_生活助手.l_逛街指数
Case 9
Get_生活指数 = l_生活助手.l_太阳镜指数
Case 10
Get_生活指数 = l_生活助手.l_感冒指数
Case 11
Get_生活指数 = l_生活助手.l_划船指数
Case 12
Get_生活指数 = l_生活助手.l_交通指数
Case 13
Get_生活指数 = l_生活助手.l_路况指数
Case 14
Get_生活指数 = l_生活助手.l_晾晒指数
Case 15
Get_生活指数 = l_生活助手.l_美发指数
Case 16
Get_生活指数 = l_生活助手.l_夜生活指数
Case 17
Get_生活指数 = l_生活助手.l_啤酒指数
Case 18
Get_生活指数 = l_生活助手.l_放风筝指数
Case 19
Get_生活指数 = l_生活助手.l_空气污染扩散条件指数
Case 20
Get_生活指数 = l_生活助手.l_化妆指数
Case 21
Get_生活指数 = l_生活助手.l_旅游指数
Case 22
Get_生活指数 = l_生活助手.l_紫外线强度指数
Case 23
Get_生活指数 = l_生活助手.l_风寒指数
Case 24
Get_生活指数 = l_生活助手.l_洗车指数
Case 25
Get_生活指数 = l_生活助手.l_心情指数
Case 26
Get_生活指数 = l_生活助手.l_运动指数
Case 27
Get_生活指数 = l_生活助手.l_约会指数
Case 28
Get_生活指数 = l_生活助手.l_雨伞指数
Case 29
Get_生活指数 = l_生活助手.l_中暑指数
End Select
End Function
Public Function Get_天气信息$(ByVal weather_value As weather_info)
Select Case weather_value
Case 0
Get_天气信息 = l_weather.l_cityname
Case 1
Get_天气信息 = l_weather.l_cityid
Case 2
Get_天气信息 = l_weather.l_weatherstate
Case 3
Get_天气信息 = l_weather.l_weathere
Case 4
Get_天气信息 = l_weather.l_tweatherstate
Case 5
Get_天气信息 = l_weather.l_time
Case 6
Get_天气信息 = l_weather.l_data
Case 7
Get_天气信息 = l_weather.l_tem1
Case 8
Get_天气信息 = l_weather.l_tem2
Case 9
Get_天气信息 = l_weather.l_temnow
Case 10
Get_天气信息 = l_weather.l_temfnow
Case 11
Get_天气信息 = l_weather.l_tsd
Case 12
Get_天气信息 = l_weather.l_tfl
Case 13
Get_天气信息 = l_weather.l_sfl
Case 14
Get_天气信息 = l_weather.l_wse
Case 15
Get_天气信息 = l_weather.l_qy
Case 16
Get_天气信息 = l_weather.l_njd
Case 17
Get_天气信息 = l_weather.l_rain
Case 18
Get_天气信息 = l_weather.l_sd
Case 19
Get_天气信息 = l_weather.l_weatherCode
Case 20
Get_天气信息 = l_weather.l_weathercoded
Case 21
Get_天气信息 = l_weather.l_weathercoden
Case 22
Get_天气信息 = l_weather.l_warning_Province
Case 23
Get_天气信息 = l_weather.l_warning_City
Case 24
Get_天气信息 = l_weather.l_warning_District
Case 25
Get_天气信息 = l_weather.l_warning_ID
Case 26
Get_天气信息 = l_weather.l_warning_Name
Case 27
Get_天气信息 = l_weather.l_warning_Color_ID
Case 28
Get_天气信息 = l_weather.l_warning_Color_name
Case 29
Get_天气信息 = l_weather.l_warning_Time
Case 30
Get_天气信息 = l_weather.l_warning_Dinfo
Case 31
Get_天气信息 = l_weather.l_warning_Dinfo_ID
Case 32
Get_天气信息 = l_weather.l_warning_Dinfo_url
Case 33
Get_天气信息 = l_weather.l_warning_Date
Case 34
Get_天气信息 = l_weather.l_warning_Caption
End Select
End Function
'__________________天气数据
Public Sub Refresh(Optional mode$ = "ID", Optional valueA$, Optional valueB#, Optional valueC#)
l_QQmap_key = Get_qqkey '重新拉取QQ_map_key
Restation
Select Case mode
Case "ID"
If valueA = "" Then Debug.Print "Refresh错误/。": Exit Sub
'从ID查询
Call Get_weather_ID(valueA)
Case Is <> "ID"
If valueB = CDbl(0) Or valueC = CDbl(0) Then Debug.Print "Refresh错误/。": Exit Sub
'从经纬度查询
Call Get_weather_ID(Me.Get_ID_for_lat_lon(valueB, valueC))
Call Get_weather_lat_lon(valueB, valueC)
End Select
Restation_false
End Sub
'__________返回ID
Public Function Get_ID_forRegion$(省级 As String, 地级 As String, Optional 县级 As String = "城区")
Get_ID_forRegion = Region.Item(省级 & "|" & 地级 & "|" & 县级)
If Get_ID_forRegion = "" Then Get_ID_forRegion = "错误代码：" & l_Error.NotID
End Function
'___________获取降水预报
Public Function Get_precipitation$(lat#, lon#) '参数 经纬度 double类型 'precipitation -- 降水
'例如：msg=雨渐小，10分钟转为中雨，不过20分钟后又开始下大雨
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'GET http://wx.weather.com.cn/citylist/city3jdata/station/xxxxxx.html HTTP/1.1
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Host", "d3.weather.com.cn"
head.Add "Connection", "keep-alive"
head.Add "Sec-Fetch-Mode", "no-cors"
head.Add "Sec-Fetch-site", "same-site"
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cookie", "vjuids=2070ff67c.16c89403963.0.1a78f612e5e5c; f_city=%E5%8C%97%E4%BA%AC%7C101010100%7C; UM_distinctid=16c894042b79a-0717ffb4a50a3-7373e61-1fa400-16c894042b88d1; Wa_lvt_3=1565696190; vjlast=1565670783.1565748260.13; Hm_lvt_080dabacb001ad3dc8b9b9049b36d43b=1565710115,1565745158,1565758742,1565762935; Wa_lvt_1=1565710115,1565745158,1565758742,1565762935; Hm_lpvt_080dabacb001ad3dc8b9b9049b36d43b=1565762975; Wa_lvt_2=1565695933,1565702414,1565763142; Wa_lpvt_2=1565763386; Wa_lpvt_1=1565763397"
head.Add "Referer", "http://wx.weather.com.cn/"
Set http.RequestHeader = head
'http.SetInfo "https://d3.weather.com.cn/webgis_rain_new/webgis/minute?lat=" & CStr(lat) & "&lon=" & CStr(lon) & "&stationid=101280502&callback=_jsonpqxkcyogtfe", "UTF-8"
http.SetInfo "https://d3.weather.com.cn/webgis_rain_new/webgis/minute?lat=" & CStr(lat) & "&lon=" & CStr(lon) & "&callback=_jsonpqxkcyogtfe", "UTF-8"
Get_precipitation = http.Get_RetString
Dim startA As Integer, startB As Integer
startA = InStr(Get_precipitation, "msg") + 6
startB = InStr(Get_precipitation, "times") - 3
Get_precipitation = Mid(Get_precipitation, startA, startB - startA)
End Function
'_________获取天气信息(经纬度)
Public Function Get_weather_lat_lon(ByRef lat#, ByRef lon#)
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
head.Add "Accept", "*/*"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Host", "forecast.weather.com.cn"
head.Add "Connection", "keep-alive"
head.Add "Sec-Fetch-Mode", "cors"
head.Add "Sec-Fetch-Site", "same-site"
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Origin", "http://wx.weather.com.cn"
head.Add "Referer", "http://wx.weather.com.cn/"
'通过经纬度查询[腾讯地图的经纬度坐标]天气[WS风级 风态 相对湿度 天气状态 实时温度]
'GET https://forecast.weather.com.cn/town/api/v1/sk?lat=23.310817&lng=116.360416 HTTP/1.1
'Host: forecast.weather.com.cn
'Connection: keep-alive
'Accept: application/json, text/plain, */*
'User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36
'Sec-Fetch-Mode: cors
'Origin: http://wx.weather.com.cn
'Sec-Fetch-Site: same-site
'Referer: http://wx.weather.com.cn/
'Accept-Encoding: gzip, deflate, br
'Accept-Language: zh-CN,zh;q=0.9,en;q=0.8
Set http.RequestHeader = head
http.SetInfo "https://forecast.weather.com.cn/town/api/v1/sk?lat=" & CStr(lat) & "&lng=" & CStr(lon), "UTF-8"
'Dim map$(5): map(0) = "WS": map(1) = "WD": map
Get_weather_lat_lon = Trim_weather(http.Get_RetString)
Debug.Print Get_weather_lat_lon
l_weather.l_sfl = ""
l_weather.l_sfl = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "WD") + 2, InStr(Get_weather_lat_lon, "temp") - InStr(Get_weather_lat_lon, "WD") - 2)
l_weather.l_temnow = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "temp") + 4, InStr(Get_weather_lat_lon, "weather") - InStr(Get_weather_lat_lon, "temp") - 4) & "℃"
l_weather.l_sfl = l_weather.l_sfl & Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "WS") + 2, InStr(Get_weather_lat_lon, "WD") - InStr(Get_weather_lat_lon, "WS") - 2)
l_weather.l_sd = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "humidity") + 8, 2) & "%"
l_weather.l_weatherCode = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "weathercode") + 11, InStr(Get_weather_lat_lon, "humidity") - InStr(Get_weather_lat_lon, "weathercode") - 11)
l_weather.l_weatherstate = Get_WeatherState(Trim_Num(l_weather.l_weatherCode))
End Function
'__________返回信息
Public Function Get_Page$()
Get_Page = Page
End Function
'_____________获取hourdata()
Public Function Get_hourdata$(ByVal page_ID)
'找了很久,也没有找到县级区域的二十四小时接口,
Dim http As New clsSHttp, url$
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Upgrade-Insecure-Requests", "1"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
url = "http://www.weather.com.cn/weather1dn/" & page_ID & ".shtml"
'________________________________________
Set http.RequestHeader = head
http.SetInfo url, "UTF-8"
Debug.Print url
Dim temp$
temp = Trim_weatherC(http.Get_RetString)
Get_hourdata = Mid(temp, InStr(temp, "varhour3data") + Len("varhour3data"), InStr(temp, "varhour3week") - InStr(temp, "varhour3data") - Len("varhour3data"))
Debug.Print Get_hourdata
End Function
'___________从ID处理天气信息
Public Sub Get_weather_ID(ByVal page_ID$)
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Host", "d1.weather.com.cn"
head.Add "Upgrade-Insecure-Requests", "1"
head.Add "Cookie", "vjuids=2070ff67c.16c89403963.0.1a78f612e5e5c; f_city=%E5%8C%97%E4%BA%AC%7C101010100%7C; UM_distinctid=16c894042b79a-0717ffb4a50a3-7373e61-1fa400-16c894042b88d1; Wa_lvt_3=1565696190; Wa_lvt_2=1565695933,1565702414; Hm_lvt_080dabacb001ad3dc8b9b9049b36d43b=1565702657,1565709842,1565710115,1565745158; Wa_lvt_1=1565702657,1565709842,1565710115,1565745158; vjlast=1565670783.1565748260.13; Wa_lpvt_1=1565751809; Hm_lpvt_080dabacb001ad3dc8b9b9049b36d43b=1565751933"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Referer", "http://forecast.weather.com.cn/town/weather1dn/" & page_ID & ".shtml"
'检测ID状态
Dim url As String
Dim city As Boolean
If Len(page_ID) = 12 Then '镇乡和城区的接口切换
url = "http://d1.weather.com.cn/dingzhi/" & page_ID & ".html"
Else
url = "http://d1.weather.com.cn/weather_index/" & page_ID & ".html"
city = True
End If
'Get请求
Set http.RequestHeader = head
http.SetInfo url, "UTF-8"
'获取JS数据
Page = " 小林查询" & Time & vbCrLf & http.Get_RetString
Dim page_value$()
Dim d$()
page_value = Split(Page, "var")
If city Then
Dim a%
'过滤字符串
For a = 1 To UBound(page_value)
d = Split(page_value(a), ",")
Call station(True, d, a)
Next
Call Set_hourdata(Get_hourdata(page_ID)) '设置二十小时预报
Else
'过滤字符串
d = Split(page_value(1), ",")
'__________________________________________
'
'先过一遍城区的数据
Call Get_weather_ID(Left(page_ID, 9))
Call station(False, d, 1)
Dim fore_cast_value_1h$(), fore_cast_default$() '24小时预报 实时预报
Call Get_foreCase_info(fore_cast_value_1h, fore_cast_default, page_ID)
Call Set_foreCase_info(fore_cast_value_1h, fore_cast_default)
End If
End Sub
'获取主节点的下一个ID
Public Function Get_ID_for_SubOrdinate$(ByVal PageID, ByVal jdname) '节点ID,欲搜索的节点名
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'_____________________________获得子节点
'Get参数
head.Add "Accept", "application/javascript, */*;q=0.8"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Host", "d1.weather.com.cn"
head.Add "Upgrade-Insecure-Requests", "1"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Referer", "http://forecast.weather.com.cn/town/weather1dn/101280601005.shtml"
Set http.RequestHeader = head
http.SetInfo "http://d1.weather.com.cn/index_around_2017/" & PageID & ".html", "UTF-8"
Get_ID_for_SubOrdinate = Trim_weather(http.Get_RetString)
Dim jd$()
jd = Split(Get_ID_for_SubOrdinate, "an")
Call Trim_Ac(jd)
Dim i%
For i = 0 To UBound(jd)
If InStr(jd(i), jdname) <> 0 Then
Get_ID_for_SubOrdinate = Trim_ABCD(jd(i))
Exit Function
End If
Next
Get_ID_for_SubOrdinate = PageID
End Function
'______________返回信息
Public Function station(ByVal city As Boolean, ByRef Value$(), Optional mode)
If mode = 4 Then
Call Set_dataZs_info(Value)
Exit Function
End If
Dim Line_s$, i%
'___________1-3
l_weather.l_tfl = ""
For i = 0 To UBound(Value)
Line_s = Trim_weather(Value(i))
'截取字符串
Select Case mode
Case Is = 1
Call Set_cityDz_info(Line_s)
Case Is = 2
Call Set_alrmDz_info(Line_s)
Case Is = 3
Call Set_dataSK_info(Line_s)
End Select
Next
End Function
'__________经纬度转地址 [返回格式 坐标地址: XXX 地名:XXX]
Public Function Get_map_for_lat_lon$(lat#, lon#)
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Host", "apis.map.qq.com"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Referer", "https://apis.map.qq.com"
Set http.RequestHeader = head
Dim url$
url = "https://apis.map.qq.com/ws/geocoder/v1/?location=" & lat & "," & lon & "&key=" & l_QQmap_key & "&get_poi=0&output=json"
http.SetInfo url, "UTF-8"
Get_map_for_lat_lon = http.Get_RetString
Debug.Print Get_map_for_lat_lon
Call Trim_Addr(Get_map_for_lat_lon, lat, lon)
End Function
Public Function Get_ID_for_lat_lon(lat#, lon#)
'这个是抓了好几次才找到地域解析的接口 [它应该也是调用的腾讯地图 然后对接自己的数据]
'加上 逆地址解析接口 ：https://lbs.qq.com/webservice_v1/guide-gcoder.html
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Host", "apis.map.qq.com"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Referer", "https://apis.map.qq.com"
Set http.RequestHeader = head
Dim url$
' https://d1.weather.com.cnhttps://d4.weather.com.cn/geong/v1/api?params={"method":"stationinfo","lat":44.166291,"lng":80.468755,"callback":"getData"}
url = "https://apis.map.qq.com/ws/geocoder/v1/?location=" & lat & "," & lon & "&key=" & l_QQmap_key & "&get_poi=0&output=json"
http.SetInfo url, "UTF-8"
Get_ID_for_lat_lon = Trim_weather(http.Get_RetString)
'__________________腾讯的解析
'___________________________________________
Debug.Print Get_ID_for_lat_lon
Dim town_title$
'ad_info_name = Mid(Get_ID_for_lat_lon, InStr(Get_ID_for_lat_lon, "adinfo"), 100)
'ad_info_name = Mid(ad_info_name, InStr(ad_info_name, "name") + 4, InStr(ad_info_name, "location") - InStr(ad_info_name, "name") - 4)
'获取 乡镇_街道名
town_title = Mid(Get_ID_for_lat_lon, InStr(Get_ID_for_lat_lon, "town"), 100)
town_title = Mid(town_title, InStr(town_title, "title") + 5, InStr(town_title, "location") - InStr(town_title, "title") - 5)
'————————————————————气象网的解析
head.RemoveAll
head.Add "Accept", "*/*"
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Connection", "keep-alive"
head.Add "Referer", "http://www.weather.com.cn/"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
Set http.RequestHeader = head
Dim urla$
urla = "{" & Chr(34) & "method" & Chr(34) & ":" & Chr(34) & "stationinfo" & Chr(34) & "," _
& Chr(34) & "lat" & Chr(34) & ":" & CStr(lat) & "," _
& Chr(34) & "lng" & Chr(34) & ":" & CStr(lon) & "," _
& Chr(34) & "callback" & Chr(34) & ":" & Chr(34) & "getDataGeo" & Chr(34) & "}": url = "https://d4.weather.com.cn/geong/v1/api?params=" & urla
Debug.Print url
http.SetInfo url, "UTF-8"
Get_ID_for_lat_lon = Trim_weather(http.Get_RetString)
'
'一开始的思路 通过三级省市区本地查找ID,然后再通过市区ID查找节点ID 0/0 但是呢，在申请省市区信息的时候,才发现json直接返回了市区ID
' 那么就直接查找节点就好了。所以下面才会有这一片注释
'Dim Lv_1$, Lv_2$, Lv3$ '三级
'Debug.Print Get_ID_for_lat_lon
'Lv_1 = Mid(Get_ID_for_lat_lon, InStr(Get_ID_for_lat_lon, "provincecn") + 10, InStrRev(Get_ID_for_lat_lon, "|") - InStr(Get_ID_for_lat_lon, "provincecn") - 10)
'Lv_2 = Mid(Get_ID_for_lat_lon, InStr(Get_ID_for_lat_lon, "distictcn") + 9, InStr(Get_ID_for_lat_lon, "provinceen") - InStr(Get_ID_for_lat_lon, "distictcn") - 9)
'LV_3 = Mid(Get_ID_for_lat_lon, InStr(Get_ID_for_lat_lon, "namecn") + 6, InStr(Get_ID_for_lat_lon, "nameen") - InStr(Get_ID_for_lat_lon, "namecn") - 6)
Dim page_ID$
page_ID = Mid(Get_ID_for_lat_lon, InStr(Get_ID_for_lat_lon, "areaid") + 6, InStr(Get_ID_for_lat_lon, "category") - InStr(Get_ID_for_lat_lon, "areaid") - 6)
'寻找符合节点的ID
Get_ID_for_lat_lon = Get_ID_for_SubOrdinate(page_ID, town_title)
'返回ID
End Function
'__________地址转经纬度 [从已知地址转换到经纬度]
Public Function Get_Addr_for_lat_lon$(ByVal Addr$, ByRef lat#, lon#) 'in out out
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Host", "apis.map.qq.com"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Referer", "https://apis.map.qq.com"
Set http.RequestHeader = head
Dim url$
url = "https://apis.map.qq.com/ws/geocoder/v1/?address=" & Addr & "&key=" & l_QQmap_key
http.SetInfo url, "UTF-8"
Get_Addr_for_lat_lon = http.Get_RetString
Call Trim_jwdB(Get_Addr_for_lat_lon, lat, lon)
End Function
'——————————获取本机IP地址[同时返回城市ID与城市名]
Public Function Get_IP_forCity$(Optional ByRef IP$, Optional ByRef ID$) 'out out
'http://wgeo.weather.com.cn/?ip=xxxxxxxxxxx
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
head.Add "Accept", "*/*"
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Connection", "keep-alive"
head.Add "Referer", "http://www.weather.com.cn/"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
Set http.RequestHeader = head
http.SetInfo "http://wgeo.weather.com.cn/ip/?_=1234567890123", "UTF-8"
Get_IP_forCity = http.Get_RetString
IP = Mid(Get_IP_forCity, InStr(Get_IP_forCity, "ip") + 4, InStr(Get_IP_forCity, Chr(34) & ";var") - 4 - InStr(Get_IP_forCity, "ip"))
ID = Mid(Get_IP_forCity, InStr(Get_IP_forCity, "id") + 4, InStr(Get_IP_forCity, Chr(34) & ";var add") - 4 - InStr(Get_IP_forCity, "id"))
Get_IP_forCity = Mid(Get_IP_forCity, InStrRev(Get_IP_forCity, "=") + 2, InStrRev(Get_IP_forCity, Chr(34) & ";") - InStrRev(Get_IP_forCity, "=") - 2)
'重新组合返回需要的格式 xxx|xxx
Dim i As Byte, tmp$()
tmp = Split(Get_IP_forCity, ",")
Get_IP_forCity = ""
For i = 0 To UBound(tmp)
Get_IP_forCity = Get_IP_forCity & tmp(i)
If i <= (UBound(tmp) - 1) Then Get_IP_forCity = Get_IP_forCity & "|"
Next
End Function
'——————————获取IP的经纬度[必需要有腾讯地图的Key] / IP定位
Public Function Get_lat_lon_forIP$(ByVal IP$, ByRef lat#, ByRef lon#) 'in out out
Dim http As New clsSHttp
Set http = New clsSHttp
head.RemoveAll
'Get参数
head.Add "Accept", "*/*"
'head.Add "Accept-Encoding", ""
head.Add "Accept-Language", "zh-CN,zh;q=0.9,en;q=0.8"
head.Add "Cache-Control", "no-cache"
head.Add "Connection", "keep-alive"
head.Add "Host", "apis.map.qq.com"
head.Add "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/76.0.3809.100 Safari/537.36"
head.Add "Referer", "https://apis.map.qq.com"
Set http.RequestHeader = head
Dim url$
url = "https://apis.map.qq.com/ws/location/v1/ip?ip=" & IP & "&key=" & l_QQmap_key
http.SetInfo url, "UTF-8"
Get_lat_lon_forIP = http.Get_RetString
Call Trim_jwd(Get_lat_lon_forIP, lat, lon)
End Function
工程文件：
似乎不能上传附件？那这样把，把下面的图片另存到你的电脑，然后用压缩软件打开（.7z）格式。
