前言.
[如果使用过程有什么问题可以QQ或邮箱联系我。 1919988942 | [email protected]]
______________________________________________
这大概是我做的最累的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 : [email protected] / [email protected] '____________________________________________________ '—————————————————————————————————————————————————————————————————————————————————————————————————————————————————— '__________________设计出发是随时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）格式。
