前言.

　　[如果使用过程有什么问题可以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 SubPrivate 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 SubPrivate Sub Command6_Click()
Call test
End SubPrivate 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 Stringl_空调开启指数 As Stringl_过敏指数 As Stringl_晨练指数 As Stringl_舒适度指数 As Stringl_穿衣指数 As Stringl_钓鱼指数 As Stringl_防晒指数 As Stringl_逛街指数 As Stringl_太阳镜指数 As Stringl_感冒指数 As Stringl_划船指数 As Stringl_交通指数 As Stringl_路况指数 As Stringl_晾晒指数 As Stringl_美发指数 As Stringl_夜生活指数 As Stringl_啤酒指数 As Stringl_放风筝指数 As Stringl_空气污染扩散条件指数 As Stringl_化妆指数 As Stringl_旅游指数 As Stringl_紫外线强度指数 As Stringl_风寒指数 As Stringl_洗车指数 As Stringl_心情指数 As Stringl_运动指数 As Stringl_约会指数 As Stringl_雨伞指数 As Stringl_中暑指数 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_ErrorNotID = &H1ANotRegion = &HBNotVar = &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 0Get_WeatherState = "晴"Case 1Get_WeatherState = "多云"Case 2Get_WeatherState = "阴"Case 3Get_WeatherState = "阵雨"Case 4Get_WeatherState = "雷阵雨"Case 5Get_WeatherState = "雷阵雨伴有冰雹"Case 6Get_WeatherState = "雨夹雪"Case 7Get_WeatherState = "小雨"Case 8Get_WeatherState = "中雨"Case 9Get_WeatherState = "大雨"Case 10Get_WeatherState = "暴雨"Case 11Get_WeatherState = "大暴雨"Case 12Get_WeatherState = "特大暴雨"Case 13Get_WeatherState = "阵雪"Case 14Get_WeatherState = "小雪"Case 15Get_WeatherState = "中雪"Case 16Get_WeatherState = "大雪"Case 17Get_WeatherState = "暴雪"Case 18Get_WeatherState = "雾"Case 19Get_WeatherState = "冻雨"Case 20Get_WeatherState = "沙尘暴"Case 21Get_WeatherState = "小到中雨"Case 22Get_WeatherState = "中到大雨"Case 23Get_WeatherState = "大到暴雨"Case 24Get_WeatherState = "暴雨到大暴雨"Case 25Get_WeatherState = "大暴雨到特大暴雨"Case 26Get_WeatherState = "小到中雪"Case 27Get_WeatherState = "中到大雪"Case 28Get_WeatherState = "大到暴雪"Case 29Get_WeatherState = "浮尘"Case 30Get_WeatherState = "扬沙"Case 31Get_WeatherState = "强沙尘暴"Case 53Get_WeatherState = "霾"Case 99Get_WeatherState = "无"Case 32Get_WeatherState = "浓雾"Case 49Get_WeatherState = "强浓雾"Case 54Get_WeatherState = "中度霾"Case 55Get_WeatherState = "重度霾"Case 56Get_WeatherState = "严重霾"Case 57Get_WeatherState = "大雾"Case 58Get_WeatherState = "特强浓雾"Case 301Get_WeatherState = "雨"Case 302Get_WeatherState = "雪"Case ElseGet_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 0Get_WindState = "无持续风向"Case 1Get_WindState = "东北风"Case 2Get_WindState = "东风"Case 3Get_WindState = "东南风"Case 4Get_WindState = "南风"Case 5Get_WindState = "西南风"Case 6Get_WindState = "西风"Case 7Get_WindState = "西北风"Case 8Get_WindState = "北风"Case 9Get_WindState = "旋转风"
End Select
End Function
Private Function Get_WinsState$(ID$)
Dim 风级编号 As Integer
风级编号 = CInt(ID)
Select Case 风级编号Case 0Get_WinsState = "<3级"Case 1Get_WinsState = "3-4级"Case 2Get_WinsState = "4-5级"Case 3Get_WinsState = "5-6级"Case 4Get_WinsState = "6-7级"Case 5Get_WinsState = "7-8级"Case 6Get_WinsState = "8-9级"Case 7Get_WinsState = "9-10级"Case 8Get_WinsState = "10-11级"Case 9Get_WinsState = "11-12级"
End Select
End Function
'___________加载地图字典
Private Sub Dic_Load(ByVal File$)
On Error GoTo 404
Dim s$Open File For Input As #1s = 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.NotRegionEnd
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 ThenValue = Mid(Value, c + Len(cityDZ(i)), Len(Value) - Len(cityDZ(i)))Select Case iCase 0l_weather.l_weathercoden = ValueCase 1l_weather.l_tem1 = ValueCase 2l_weather.l_tem2 = ValueCase 3l_weather.l_cityname = ValueCase 4l_weather.l_tfl = l_weather.l_tfl & Value '级别Case 5l_weather.l_tfl = l_weather.l_tfl & Value '风向Case 6l_weather.l_time = Mid(Value, 1, 2) & ":" & Mid(Value, 3, 2)Case 7l_weather.l_weathercoded = ValueCase 8l_weather.l_tweatherstate = ValueCase 9l_weather.l_cityid = ValueEnd SelectExit SubEnd 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 23l_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 iiCase 0l_1day(i).l_timenow = Mid(value_1h(ii), 5, 2)Case 1l_1day(i).l_weatherCode = Mid(value_1h(ii), Len("weathercode") + 1, Len(value_1h(ii)) - Len("weathercode"))Case 2l_1day(i).l_weather = Mid(value_1h(ii), Len("weather") + 1, Len(value_1h(ii)) - Len("weather"))Case 3l_1day(i).l_temnow = Mid(value_1h(ii), Len("temp") + 1, Len(value_1h(ii)) - Len("temp")) & "℃"Case 4l_1day(i).l_windstate = Mid(value_1h(ii), Len("windL") + 1, Len(value_1h(ii)) - Len("windL"))Case 5l_1day(i).l_windstate = Mid(value_1h(ii), Len("windD") + 1, Len(value_1h(ii)) - Len("windD")) & l_1day(i).l_windstateEnd SelectNextNext'实时预报Dim tmp_default$For i = 1 To 8Select Case iCase 1l_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 3l_weather.l_temnow = Mid(cast_default(i), Len("temp") + 1, Len(cast_default(i)) - Len("temp")) & "℃"End SelectNext
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) <> "" ThenSet_foreCase_info_value_1h_list = Set_foreCase_info_value_1h_list & Value(i) & ","ElseStart = i + 2Exit FunctionEnd IfNext
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 iCase 0l_weather.l_cityname = Value '地域名称Case 1l_weather.l_temfnow = Value & "℉" '实时气温 华氏度Case 2l_weather.l_sfl = Value '风向Case 3l_weather.l_sfl = l_weather.l_sfl & Value '加上风级Case 4l_weather.l_wse = Trim_wse(Value) & "km/h" '风速Case 5l_weather.l_sd = Value '湿度Case 6Value = Mid(Value, 1, 2) & ":" & Mid(Value, 3, 2)l_weather.l_time = ValueCase 7l_weather.l_qy = Value '气压Case 8l_weather.l_njd = Value '能见度Case 9Exit SubCase 10l_weather.l_data = Value '日期Case 11l_weather.l_cityid = Value '地域代码Case 12l_weather.l_temnow = Value & "℃" '实时气温 摄氏度Case 13l_weather.l_weatherCode = ValueCase 14l_weather.l_rain = Value '降雨量Case 15l_weather.l_weathere = Value '气象状态英文Case 16l_weather.l_weatherstate = Value '气象状态End SelectExit SubEnd If
Next
End Sub
Private Sub Set_hourdata(ByVal Value$)
Dim i%, s$(), ii%
s = Split(Value, ",")
For i = 0 To 143 Step 6For ii = 0 To 5Select Case iiCase 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 SelectNext
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 iCase 0l_weather.l_warning_Province = ValueCase 1l_weather.l_warning_City = ValueCase 2l_weather.l_warning_District = ValueCase 3l_weather.l_warning_ID = ValueCase 4l_weather.l_warning_Name = ValueCase 5l_weather.l_warning_Color_ID = ValueCase 6l_weather.l_warning_Color_name = ValueCase 7l_weather.l_warning_Time = ValueCase 8l_weather.l_warning_Dinfo = ValueCase 9l_weather.l_warning_Dinfo_ID = ValueCase 10l_weather.l_warning_Dinfo_url = ValueCase 11l_weather.l_warning_Date = ValueCase 12l_weather.l_warning_Caption = ValueEnd SelectExit SubEnd 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 lengthSelect Case iCase 0l_生活助手.l_data = Value(i)Case 1 * lengthl_生活助手.l_空调开启指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 2 * lengthl_生活助手.l_过敏指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 3 * lengthl_生活助手.l_晨练指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 4 * lengthl_生活助手.l_舒适度指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 5 * lengthl_生活助手.l_穿衣指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 6 * lengthl_生活助手.l_钓鱼指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 7 * lengthl_生活助手.l_防晒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 8 * lengthl_生活助手.l_逛街指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 9 * lengthl_生活助手.l_太阳镜指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 10 * lengthl_生活助手.l_感冒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 11 * lengthl_生活助手.l_划船指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 12 * lengthl_生活助手.l_交通指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 13 * lengthl_生活助手.l_路况指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 14 * lengthl_生活助手.l_晾晒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 15 * lengthl_生活助手.l_美发指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 16 * lengthl_生活助手.l_夜生活指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 17 * lengthl_生活助手.l_啤酒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 18 * lengthl_生活助手.l_放风筝指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 19 * lengthl_生活助手.l_空气污染扩散条件指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 20 * lengthl_生活助手.l_化妆指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 21 * lengthl_生活助手.l_旅游指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 22 * lengthl_生活助手.l_紫外线强度指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 23 * lengthl_生活助手.l_风寒指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 24 * lengthl_生活助手.l_洗车指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 25 * lengthl_生活助手.l_心情指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 26 * lengthl_生活助手.l_运动指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 27 * lengthl_生活助手.l_约会指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 28 * lengthl_生活助手.l_雨伞指数 = Value(i - 2) & ":" & Value(i - 1) & vbCrLf & Value(i)Case 29 * lengthl_生活助手.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" ThenTrim_Num = Trim_Num & sEnd 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
NextTrim_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 23If 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 23l_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 ThenOutValue(0) = "预报时间：  " & l_1day(i).l_timenowOutValue(1) = "预测当时气温：  " & l_1day(i).l_temnowOutValue(2) = "预测当时风向风力  " & l_1day(i).l_windstateOutValue(3) = "预测当时相对湿度：  " & l_1day(i).l_sdOutValue(4) = "预测当时天气情况：  " & l_1day(i).l_weather
Exit Sub
End If
Next
End Sub
'返回十二时辰列表的日期
Public Function Get_十二时辰_日期$(ByVal Value%)
If Value <= 24 And Value >= 1 ThenGet_十二时辰_日期 = 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:DoEventsSet http = New clsSHttphead.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 = headDim 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 clsSHttphead.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 = headhttp.SetInfo url, "UTF-8"
Line1:Dim temp$, count%temp = Trim_weatherD(http.Get_RetString)If temp = "" ThenIf count >= 3 ThenGoTo Line2End Ifcount = count + 1GoTo Line1End IfGet_qqkey = Mid(temp, InStr(temp, "vargeolocationnewqqmapsGeolocation") + Len("vargeolocationnewqqmapsGeolocation"), InStr(temp, ",jsybdocumentgetElementBy") - InStr(temp, "vargeolocationnewqqmapsGeolocation") - Len("vargeolocationnewqqmapsGeolocation"))
Line2:If Get_qqkey = "" ThenMsgBox "获取气象网使用的腾讯地图——key失败,将启用备用Key."Get_qqkey = l_备用的QQkeyEnd If
End Function
Public Function Get_生活指数$(ByVal Value As life_Num)Select Case ValueCase 0Get_生活指数 = l_生活助手.l_dataCase 1Get_生活指数 = l_生活助手.l_空调开启指数Case 2Get_生活指数 = l_生活助手.l_过敏指数Case 3Get_生活指数 = l_生活助手.l_晨练指数Case 4Get_生活指数 = l_生活助手.l_舒适度指数Case 5Get_生活指数 = l_生活助手.l_穿衣指数Case 6Get_生活指数 = l_生活助手.l_钓鱼指数Case 7Get_生活指数 = l_生活助手.l_防晒指数Case 8Get_生活指数 = l_生活助手.l_逛街指数Case 9Get_生活指数 = l_生活助手.l_太阳镜指数Case 10Get_生活指数 = l_生活助手.l_感冒指数Case 11Get_生活指数 = l_生活助手.l_划船指数Case 12Get_生活指数 = l_生活助手.l_交通指数Case 13Get_生活指数 = l_生活助手.l_路况指数Case 14Get_生活指数 = l_生活助手.l_晾晒指数Case 15Get_生活指数 = l_生活助手.l_美发指数Case 16Get_生活指数 = l_生活助手.l_夜生活指数Case 17Get_生活指数 = l_生活助手.l_啤酒指数Case 18Get_生活指数 = l_生活助手.l_放风筝指数Case 19Get_生活指数 = l_生活助手.l_空气污染扩散条件指数Case 20Get_生活指数 = l_生活助手.l_化妆指数Case 21Get_生活指数 = l_生活助手.l_旅游指数Case 22Get_生活指数 = l_生活助手.l_紫外线强度指数Case 23Get_生活指数 = l_生活助手.l_风寒指数Case 24Get_生活指数 = l_生活助手.l_洗车指数Case 25Get_生活指数 = l_生活助手.l_心情指数Case 26Get_生活指数 = l_生活助手.l_运动指数Case 27Get_生活指数 = l_生活助手.l_约会指数Case 28Get_生活指数 = l_生活助手.l_雨伞指数Case 29Get_生活指数 = l_生活助手.l_中暑指数End Select
End Function
Public Function Get_天气信息$(ByVal weather_value As weather_info)Select Case weather_valueCase 0Get_天气信息 = l_weather.l_citynameCase 1Get_天气信息 = l_weather.l_cityidCase 2Get_天气信息 = l_weather.l_weatherstateCase 3Get_天气信息 = l_weather.l_weathereCase 4Get_天气信息 = l_weather.l_tweatherstateCase 5Get_天气信息 = l_weather.l_timeCase 6Get_天气信息 = l_weather.l_dataCase 7Get_天气信息 = l_weather.l_tem1Case 8Get_天气信息 = l_weather.l_tem2Case 9Get_天气信息 = l_weather.l_temnowCase 10Get_天气信息 = l_weather.l_temfnowCase 11Get_天气信息 = l_weather.l_tsdCase 12Get_天气信息 = l_weather.l_tflCase 13Get_天气信息 = l_weather.l_sflCase 14Get_天气信息 = l_weather.l_wseCase 15Get_天气信息 = l_weather.l_qyCase 16Get_天气信息 = l_weather.l_njdCase 17Get_天气信息 = l_weather.l_rainCase 18Get_天气信息 = l_weather.l_sdCase 19Get_天气信息 = l_weather.l_weatherCodeCase 20Get_天气信息 = l_weather.l_weathercodedCase 21Get_天气信息 = l_weather.l_weathercodenCase 22Get_天气信息 = l_weather.l_warning_ProvinceCase 23Get_天气信息 = l_weather.l_warning_CityCase 24Get_天气信息 = l_weather.l_warning_DistrictCase 25Get_天气信息 = l_weather.l_warning_IDCase 26Get_天气信息 = l_weather.l_warning_NameCase 27Get_天气信息 = l_weather.l_warning_Color_IDCase 28Get_天气信息 = l_weather.l_warning_Color_nameCase 29Get_天气信息 = l_weather.l_warning_TimeCase 30Get_天气信息 = l_weather.l_warning_DinfoCase 31Get_天气信息 = l_weather.l_warning_Dinfo_IDCase 32Get_天气信息 = l_weather.l_warning_Dinfo_urlCase 33Get_天气信息 = l_weather.l_warning_DateCase 34Get_天气信息 = l_weather.l_warning_CaptionEnd 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 modeCase "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 clsSHttphead.RemoveAll'Get参数head.Add "Accept", "*/*"'GET http://wx.weather.com.cn/citylist/city3jdata/station/xxxxxx.html HTTP/1.1head.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_RetStringDim startA As Integer, startB As IntegerstartA = InStr(Get_precipitation, "msg") + 6startB = InStr(Get_precipitation, "times") - 3Get_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 clsSHttphead.RemoveAllhead.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.8Set http.RequestHeader = headhttp.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": mapGet_weather_lat_lon = Trim_weather(http.Get_RetString)Debug.Print Get_weather_lat_lonl_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 clsSHttphead.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 = headhttp.SetInfo url, "UTF-8"Debug.Print urlDim 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 clsSHttpSet http = New clsSHttphead.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 BooleanIf Len(page_ID) = 12 Then '镇乡和城区的接口切换url = "http://d1.weather.com.cn/dingzhi/" & page_ID & ".html"Elseurl = "http://d1.weather.com.cn/weather_index/" & page_ID & ".html"city = TrueEnd If'Get请求Set http.RequestHeader = headhttp.SetInfo url, "UTF-8"'获取JS数据Page = " 小林查询" & Time & vbCrLf & http.Get_RetString
Dim page_value$()
Dim d$()page_value = Split(Page, "var")If city ThenDim a%'过滤字符串For a = 1 To UBound(page_value)d = Split(page_value(a), ",")Call station(True, d, a)NextCall 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 clsSHttpSet http = New clsSHttphead.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 = headhttp.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 ThenGet_ID_for_SubOrdinate = Trim_ABCD(jd(i))Exit FunctionEnd IfNextGet_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-3l_weather.l_tfl = ""For i = 0 To UBound(Value)Line_s = Trim_weather(Value(i))'截取字符串Select Case modeCase Is = 1Call Set_cityDz_info(Line_s)Case Is = 2Call Set_alrmDz_info(Line_s)Case Is = 3Call Set_dataSK_info(Line_s)End SelectNext
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.htmlDim 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）格式。

[修复了Get_weatherstate数据不带上转的天气的BUG]

转载于:https://www.cnblogs.com/lingqingxue/p/11368102.html

VB6_小林的气象类模块相关推荐

小林求职记（六）踩过Dubbo坑，回答印象深，干货整理
小林求职记系列文章,归置到公众号菜单栏,欢迎查看历史篇前传小林求职记(五)上来就一连串的分布式缓存提问,我有点上头.... 终于,在小林的努力下,获得了王哥公司那边的offer,但是因为薪水没有谈 ...
小林求职记（五）上来就一连串的分布式缓存提问，我有点上头....
小林求职记系列文章,归置到公众号菜单栏,欢迎查看历史篇前传小林求职记(四)不会吧不会吧,面试还真会问这些呀在之前王哥的辅助之下,小明的简历成功被内推进到了王哥所在公司.由于一面就是王哥自己,所以 ...
小林求职记（三）一上来就围绕电商系统层层提问，我太难了....
前传面试官:什么是大事务?小林哥:就是很大...的...事务?? 小林求职记(二):说好的问基础,为啥我感觉一点也不基础呢? 二面的面试官来到来我的跟前,开始对我的简历进行了一番打量然后就开始了技 ...
郑小林——“浙大系”隐私计算产学研创新先锋
作为算力智库2021隐私计算年度十大人物,郑小林是产学研创新的先锋.他的首要身份是学者,是浙江大学计算机学院教授.博导,浙江大学人工智能研究所副所长.他同时也是创业者,由他创立的金智塔科技定位于隐私计 ...
小林coding操作系统总结
文章目录前言名词科普前置一.硬件结构 1.1 计算机基本结构 1.2 存储器层次结构 1.3 提升缓存命中率,提高CPU速度 1.4 缓存一致性 1.5 伪共享和CPU线程调度 1.6 中断 1 ...
小林求职记（四）不会吧不会吧，面试还真会问这些呀
小林求职记系列文章,归置到公众号菜单栏,欢迎查看历史篇前传小林求职记(三)一上来就围绕电商系统层层提问,我太难了.... 经历了好几次求职失败的经历,小林最终找到了自己以前一起工作合作的老同事王哥 ...
小林求职记（二）：说好的问基础，为啥我感觉一点也不基础呢？
精彩推荐一百期Java面试题汇总 SpringBoot内容聚合 IntelliJ IDEA内容聚合 Mybatis内容聚合在上一轮的面试中,小林在mysql方面因为作答不够完善,被面试官吊打了一番 ...
ansible笔记（8）：常用模块之系统类模块（二）
ansible笔记(8):常用模块之系统类模块(二)user模块 user模块可以帮助我们管理远程主机上的用户,比如创建用户.修改用户.删除用户.为用户创建密钥对等操作.此处我们介绍一些user模块的 ...
【苏小林主页】基于TP6和光年模板的个人主页
基于光年V4和thinkphp的个人主页开源仓库地址:GitHub - suxaiolin/personal: 个人主页(带后台) - su personal 直链下载地址:苏小林个人主页带后台管理 ...
观小林coding图解网络总结
前言:本文属于二次创作,基于自己的理解,将重点做了总结,个人总结会比较简洁,而且有所倾向(不然就原封不动复制粘贴了),可以现简单看一下这个总结,知道有哪些知识点,具体哪些知识点感兴趣的就可以去看看原文 ...

VB6_小林的气象类模块

前言.

模块代码：

工程文件：

VB6_小林的气象类模块相关推荐

最新文章

热门文章