VB6_小林的气象类模块
前言.
[如果使用过程有什么问题可以QQ或邮箱联系我。 1919988942 | w2638301509@gmail.com]
______________________________________________
这大概是我做的最累的VB6作品，啊...累死了.....。
[并且我也懒得花心思去改代码了,里面有非常非常多的垃圾代码,但是对VB新手初学者而言,这个类模块非常适合你学习。因为简单且易懂]
第一次玩编程熬到四点.....感觉整个人都不好了。
类模块所有的气象数据都来源于中国气象网的各个平台,{手机微信PC和其他一些挖到的接口},定位服务,逆地址解析服务等来源于腾讯地图的WebAPI。
先上一下使用类模块的实例截图
代码如下：
'部分示例
Private Sub Command1_Click()
Dim i As 小林的天气模块
Set i = New 小林的天气模块
'i.Set_ID (i.Get_ID_forRegion("吉林", "磐石"))
'Call i.Refresh(, i.Get_ID_forRegion("吉林", "磐石"))
'23.3175479108, 116.3527464867
'Call i.Refresh("map", , 43.8504363962, 126.5322875977)
'MsgBox i.Get_生活指数(生活助手.l_穿衣指数)
Dim IP$, ID$, city$
city = i.Get_IP_forCity(IP, ID) '从本地IP中获取地点名称和地点编号
Dim lat#, lon#
Call i.Get_lat_lon_forIP(IP, lat, lon) '从IP中获取地点的经纬度
MsgBox "获取到的市名/地点名 :" & city
MsgBox "获取到的IP：" & IP
MsgBox "获取到的ID：" & ID
MsgBox "腾讯地图返回的经度:" & lon
MsgBox "腾讯地图返回的纬度:" & lat
MsgBox i.Get_map_for_lat_lon(lat, lon) '从经纬度获取地理位置地址
MsgBox "降水播报:" & vbCrLf & city & vbCrLf & i.Get_precipitation(lat, lon) '从经纬度获取该位置的降雨预报
Call i.Refresh(, ID) '从地点编号获取地点的气象情况 '{[Refresh 参数如下：
'[Mode : -ID/-经纬度 - 默认使用ID|传任意参数即使用经纬度]
'[ID ： 可空,但如果经纬度也空的话,会通过Debug返回Refresh错误/。]
'[纬度] ： 可空，但如果ID或者经度也空的话，会通过Debug返回Refresh错误/。]
'[经度] ： 可空，但如果ID或者纬度也空的话，会通过Debug返回Refresh错误/。] '功能:翻译经纬度为ID，使用ID得到气象数据
']} MsgBox i.Get_生活指数(l_穿衣指数) '获取生活指数 参数见生活助手枚举列表
End Sub Private Sub Command2_Click()
'经纬度获取示例 ' [传参时 统一以纬度为先]
Dim lat#, lon# '定义经纬度 Dim i As 小林的天气模块
Set i = New 小林的天气模块 '从具体地址获取经纬度
MsgBox i.Get_Addr_for_lat_lon("广东省深圳市南山区南海大道3688号", lat, lon)
MsgBox "腾讯地图返回的经度:" & lon
MsgBox "腾讯地图返回的纬度:" & lat
'从本机IP地址获取经纬度
Dim IP$ '定义IP
'获取本机IP [v4]
Call i.Get_IP_forCity(IP)
MsgBox i.Get_lat_lon_forIP(IP, lat, lon)
MsgBox "腾讯地图返回的经度:" & lon
MsgBox "腾讯地图返回的纬度:" & lat
End Sub
Private Sub Command4_Click()
Dim i As 小林的天气模块
Set i = New 小林的天气模块
'国外ID[地点编号]获取方式：
'暂无 | 这个模块暂时没有办法获取国外天气 /。ps:因为我没有去找国外天气的接口
'_______________________________________________
'国内ID获取方式:
'1. '字典查询ID [只能查询到第三级 ] ：
'Get_ID_forRegion '从本地文件中查找编号 [省份,市名]
'带特别行政区名的级地域名必须声明国家！[],例如 :
MsgBox i.Get_ID_forRegion("中国香港", "中国香港", "新界")
MsgBox i.Get_ID_forRegion("中国澳门", "中国澳门", "氹仔岛")
MsgBox i.Get_ID_forRegion("中国台湾", "台北", "新竹")
'假设你要找直辖市,或城市的ID,直接填入前两级的参数即可
MsgBox i.Get_ID_forRegion("中国香港", "中国香港")
MsgBox i.Get_ID_forRegion("新疆", "克拉玛依")
MsgBox i.Get_ID_forRegion("广东", "深圳")
'2. 经纬度查询ID [精确到四级行政区 - 乡镇街道]
'Get_ID_for_lat_lon --- [纬度,经度]
'MsgBox i.Get_ID_for_lat_lon(44.166291, 80.468755)
'3. 二/三级的ID,和它的下级，三级/四级的地名，查询三级四级的ID [下面这个函数将返回茶山镇的ID]
MsgBox i.Get_ID_for_SubOrdinate(i.Get_ID_forRegion("广东", "东莞"), "茶山镇") '___________________________________________
'使用示例： i.Refresh , , 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 = To
List1.AddItem "_____小林的分割线___________"
Call i.Get_十二时辰(i.Get_十二时辰_日期(k), sc12) '提示：一个时辰=两个小时
For kk = 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 =
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 = '地域名 ------ "延边新兴工业集中区
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() 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 = Then ReDim c(): c() = CInt(Mid(ID, , )): c() = CInt(Mid(ID, , ))
If length = Then ReDim c(): c() = CInt(Mid(ID, , )): c() = CInt(Mid(ID, , ))
If length = Then ReDim c(): c() = CInt(Mid(ID, , )): c() = CInt(Mid(ID, , ))
If length = Then ReDim c(): c() = CInt(ID)
For i = To UBound(c)
气象编号 = c(i)
Select Case 气象编号
Case
Get_WeatherState = "晴"
Case
Get_WeatherState = "多云"
Case
Get_WeatherState = "阴"
Case
Get_WeatherState = "阵雨"
Case
Get_WeatherState = "雷阵雨"
Case
Get_WeatherState = "雷阵雨伴有冰雹"
Case
Get_WeatherState = "雨夹雪"
Case
Get_WeatherState = "小雨"
Case
Get_WeatherState = "中雨"
Case
Get_WeatherState = "大雨"
Case
Get_WeatherState = "暴雨"
Case
Get_WeatherState = "大暴雨"
Case
Get_WeatherState = "特大暴雨"
Case
Get_WeatherState = "阵雪"
Case
Get_WeatherState = "小雪"
Case
Get_WeatherState = "中雪"
Case
Get_WeatherState = "大雪"
Case
Get_WeatherState = "暴雪"
Case
Get_WeatherState = "雾"
Case
Get_WeatherState = "冻雨"
Case
Get_WeatherState = "沙尘暴"
Case
Get_WeatherState = "小到中雨"
Case
Get_WeatherState = "中到大雨"
Case
Get_WeatherState = "大到暴雨"
Case
Get_WeatherState = "暴雨到大暴雨"
Case
Get_WeatherState = "大暴雨到特大暴雨"
Case
Get_WeatherState = "小到中雪"
Case
Get_WeatherState = "中到大雪"
Case
Get_WeatherState = "大到暴雪"
Case
Get_WeatherState = "浮尘"
Case
Get_WeatherState = "扬沙"
Case
Get_WeatherState = "强沙尘暴"
Case
Get_WeatherState = "霾"
Case
Get_WeatherState = "无"
Case
Get_WeatherState = "浓雾"
Case
Get_WeatherState = "强浓雾"
Case
Get_WeatherState = "中度霾"
Case
Get_WeatherState = "重度霾"
Case
Get_WeatherState = "严重霾"
Case
Get_WeatherState = "大雾"
Case
Get_WeatherState = "特强浓雾"
Case
Get_WeatherState = "雨"
Case
Get_WeatherState = "雪"
Case Else
Get_WeatherState = "查询天气失败."
End Select
If UBound(c) = And i = Then Get_WeatherState = Get_WeatherState & "转"
Next
End Function
'___________返回风力风向
Private Function Get_WindState$(ID$)
Dim 风向编号 As Integer
风向编号 = CInt(ID)
Select Case 风向编号
Case
Get_WindState = "无持续风向"
Case
Get_WindState = "东北风"
Case
Get_WindState = "东风"
Case
Get_WindState = "东南风"
Case
Get_WindState = "南风"
Case
Get_WindState = "西南风"
Case
Get_WindState = "西风"
Case
Get_WindState = "西北风"
Case
Get_WindState = "北风"
Case
Get_WindState = "旋转风"
End Select
End Function
Private Function Get_WinsState$(ID$)
Dim 风级编号 As Integer
风级编号 = CInt(ID)
Select Case 风级编号
Case
Get_WinsState = "<3级"
Case
Get_WinsState = "3-4级"
Case
Get_WinsState = "4-5级"
Case
Get_WinsState = "5-6级"
Case
Get_WinsState = "6-7级"
Case
Get_WinsState = "7-8级"
Case
Get_WinsState = "8-9级"
Case
Get_WinsState = "9-10级"
Case
Get_WinsState = "10-11级"
Case
Get_WinsState = "11-12级"
End Select
End Function
'___________加载地图字典
Private Sub Dic_Load(ByVal File$)
On Error GoTo
Dim s$
Open File For Input As #
s = ByteToStr(InputB(LOF(), #), "UTF-8")
Close #
Dim Dic_s$()
'读取内容到s
Dic_s = Split(s, vbCrLf)
'读取内容到字典
Dim i As Long
For i = To UBound(Dic_s) Step
Region.Add Dic_s(i), Dic_s(i + )
Next
Exit Sub
:
MsgBox "错误代码：" & l_Error.NotRegion
End
End Sub
'___________加载alrmDZK
Private Sub alrmDZ_Load()
ReDim alrmDZ$()
alrmDZ() = "alarmDZww1" '预警省份
alrmDZ() = "w2" '预警城市
alrmDZ() = "w3" '预警区域
alrmDZ() = "w4" '预警信号
alrmDZ() = "w5" '预警名
alrmDZ() = "w6" '预警信号级别颜色ID '例如蓝黄橙红
alrmDZ() = "w7" '预警信号级别名
alrmDZ() = "w8" ' 预警更新时间
alrmDZ() = "w9" '预警的详细信息 '例如XXX气象局于XXX升级某预警
alrmDZ() = "w10" '预警发布编号
alrmDZ() = "w11" '预警发布地址
alrmDZ() = "w12" '预警发布时间
alrmDZ() = "w13" '预警标题
End Sub
'___________加载dataSK
Private Sub dataSK_Load()
ReDim dataSK$()
dataSK() = "cityname" '地域名称
dataSK() = "tempf" '实时气温 华氏度
dataSK() = "WD" '风向
dataSK() = "WS" '风级
dataSK() = "wse" '风速
dataSK() = "SD" '相对湿度
dataSK() = "time" '更新时间
dataSK() = "qy" '气压
dataSK() = "njd" '能见度
dataSK() = "rain24h" '???24小时降水？放在这里过滤的时候才会自动排除掉____应该用不到所以没加在信息里
dataSK() = "date" '日期
dataSK() = "city" '地域代码
dataSK() = "temp" '实时气温 摄氏度
dataSK() = "weathercode" '气象代码
dataSK() = "rain" '降雨量
dataSK() = "weathere" '气象英文标识
dataSK() = "weather" '气象中文
End Sub
'___________加载City
Private Sub cityDZ_Load()
ReDim cityDZ$()
cityDZ() = "weathercoden" '这个是n的值 d-->n d转n
cityDZ() = "tempn" '最高温度
cityDZ() = "temp" '最低温度
cityDZ() = "cityname" '地名
cityDZ() = "ws" '当前风力
cityDZ() = "wd" '当前风级
cityDZ() = "fctime" '更新时间
cityDZ() = "weathercoded" '这个是d的值 d-->n d转n 例如 大雨转中雨
cityDZ() = "weather" '气象
cityDZ() = "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 = To UBound(cityDZ)
c = InStr(Value, cityDZ(i))
If c = Then
Value = Mid(Value, c + Len(cityDZ(i)), Len(Value) - Len(cityDZ(i)))
Select Case i
Case
l_weather.l_weathercoden = Value
Case
l_weather.l_tem1 = Value
Case
l_weather.l_tem2 = Value
Case
l_weather.l_cityname = Value
Case
l_weather.l_tfl = l_weather.l_tfl & Value '级别
Case
l_weather.l_tfl = l_weather.l_tfl & Value '风向
Case
l_weather.l_time = Mid(Value, , ) & ":" & Mid(Value, , )
Case
l_weather.l_weathercoded = Value
Case
l_weather.l_tweatherstate = Value
Case
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 = '忽略掉变量名
For i = To
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 = To UBound(value_1h)
'l_1day - 十二时辰
Select Case ii
Case
l_1day(i).l_timenow = Mid(value_1h(ii), , )
Case
l_1day(i).l_weatherCode = Mid(value_1h(ii), Len("weathercode") + , Len(value_1h(ii)) - Len("weathercode"))
Case
l_1day(i).l_weather = Mid(value_1h(ii), Len("weather") + , Len(value_1h(ii)) - Len("weather"))
Case
l_1day(i).l_temnow = Mid(value_1h(ii), Len("temp") + , Len(value_1h(ii)) - Len("temp")) & "℃"
Case
l_1day(i).l_windstate = Mid(value_1h(ii), Len("windL") + , Len(value_1h(ii)) - Len("windL"))
Case
l_1day(i).l_windstate = Mid(value_1h(ii), Len("windD") + , Len(value_1h(ii)) - Len("windD")) & l_1day(i).l_windstate
End Select
Next
Next
'实时预报
Dim tmp_default$
For i = To
Select Case i
Case
l_weather.l_time = Mid(cast_default(i), Len("time") + , Len(cast_default(i)) - Len("time"))
l_weather.l_time = Mid(l_weather.l_time, , ) & ":" & Mid(l_weather.l_time, , )
Case
l_weather.l_temnow = Mid(cast_default(i), Len("temp") + , 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 +
Exit Function
End If
Next
End Function
'---------------处理气象信息
Private Sub Set_dataSK_info(ByVal Value$)
Dim i%, c%
For i = To UBound(dataSK)
'验证参数
c = InStr(Value, dataSK(i))
If c = Then
'获得参数
Value = Mid(Value, c + Len(dataSK(i)), Len(Value) - Len(dataSK(i)))
'设置气象属性
Select Case i
Case
l_weather.l_cityname = Value '地域名称
Case
l_weather.l_temfnow = Value & "℉" '实时气温 华氏度
Case
l_weather.l_sfl = Value '风向
Case
l_weather.l_sfl = l_weather.l_sfl & Value '加上风级
Case
l_weather.l_wse = Trim_wse(Value) & "km/h" '风速
Case
l_weather.l_sd = Value '湿度
Case
Value = Mid(Value, , ) & ":" & Mid(Value, , )
l_weather.l_time = Value
Case
l_weather.l_qy = Value '气压
Case
l_weather.l_njd = Value '能见度
Case
Exit Sub
Case
l_weather.l_data = Value '日期
Case
l_weather.l_cityid = Value '地域代码
Case
l_weather.l_temnow = Value & "℃" '实时气温 摄氏度
Case
l_weather.l_weatherCode = Value
Case
l_weather.l_rain = Value '降雨量
Case
l_weather.l_weathere = Value '气象状态英文
Case
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 = To Step
For ii = To
Select Case ii
Case 'jc = 风级编号
l_1day(i / ).l_windstate = Get_WinsState(Trim_Num(s(ii + i)))
Case 'jb = 气温
l_1day(i / ).l_temnow = Trim_Num(s(ii + i)) & "℃"
Case 'je = 相对湿度
l_1day(i / ).l_sd = Trim_Num(s(ii + i))
Case 'jd = '风向
l_1day(i / ).l_windstate = l_1day(i / ).l_windstate & Get_WindState(Trim_Num(s(ii + i)))
Case 'jf = '日期+小时
l_1day(i / ).l_timenow = Trim_Num(s(ii + i))
Case 'ja = 天气现象编号
l_1day(i / ).l_weatherCode = Trim_Num(s(ii + i))
l_1day(i / ).l_weather = Get_WeatherState(l_1day(i / ).l_weatherCode)
End Select
Next
Next
End Sub
Private Sub Set_alrmDz_info(ByVal Value$)
Dim i%, c%
Value = Trim_weather(Value)
For i = To UBound(alrmDZ)
'验证参数
c = InStr(Value, alrmDZ(i))
If c = Then
'获得参数
Value = Mid(Value, c + Len(alrmDZ(i)), Len(Value) - Len(alrmDZ(i)))
Select Case i
Case
l_weather.l_warning_Province = Value
Case
l_weather.l_warning_City = Value
Case
l_weather.l_warning_District = Value
Case
l_weather.l_warning_ID = Value
Case
l_weather.l_warning_Name = Value
Case
l_weather.l_warning_Color_ID = Value
Case
l_weather.l_warning_Color_name = Value
Case
l_weather.l_warning_Time = Value
Case
l_weather.l_warning_Dinfo = Value
Case
l_weather.l_warning_Dinfo_ID = Value
Case
l_weather.l_warning_Dinfo_url = Value
Case
l_weather.l_warning_Date = Value
Case
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 =
Dim Line_s$, i%
Call Trim_chinese(Value) '去英文和各种特殊符号
For i = To UBound(Value) Step length
Select Case i
Case
l_生活助手.l_data = Value(i)
Case * length
l_生活助手.l_空调开启指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_过敏指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_晨练指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_舒适度指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_穿衣指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_钓鱼指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_防晒指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_逛街指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_太阳镜指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_感冒指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_划船指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_交通指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_路况指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_晾晒指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_美发指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_夜生活指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_啤酒指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_放风筝指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_空气污染扩散条件指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_化妆指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_旅游指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_紫外线强度指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_风寒指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_洗车指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_心情指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_运动指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_约会指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_雨伞指数 = Value(i - ) & ":" & Value(i - ) & vbCrLf & Value(i)
Case * length
l_生活助手.l_中暑指数 = Value(i - ) & ":" & Value(i - ) & 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") + , InStr(Value, "message") - InStr(Value, "status") - )
If status = "" Then
Debug.Print Value
lat = CDbl(Mid(Value, InStr(Value, "lat") + , InStr(Value, "lng") - InStr(Value, "lat") - ))
lon = CDbl(Mid(Value, InStr(Value, "lng") + , InStr(Value, "adinfo") - InStr(Value, "lng") - ))
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") + , InStr(Value, "message") - InStr(Value, "status") - )
If status = "" Then
Debug.Print Value
lon = CDbl(Mid(Value, InStr(Value, "lng") + , InStr(Value, "lat") - InStr(Value, "lng") - ))
lat = CDbl(Mid(Value, InStr(Value, "lat") + , InStr(Value, "adinfo") - InStr(Value, "lat") - ))
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") + , InStr(Value, "message") - InStr(Value, "status") - )
If status = "" Then
Dim address$, recommend$
'取address值
address = Mid(Value, InStr(Value, "address") + , InStr(Value, "formattedaddresses") - InStr(Value, "address") - )
recommend = Mid(Value, InStr(Value, "recommend") + , InStr(Value, "rough") - InStr(Value, "recommend") - )
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 = To i
St = Mid(ss, j, )
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "" And St1 <= "" Or _
St1 = "℃" Or St1 = "/" Or St1 = "<" Or St1 = ">" And Asc(St1) > Or _
Asc(St1) < 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 = To i
St = Mid(ss, j, )
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "" And St1 <= "" Or _
St1 = "℃" Or St1 = "/" Or St1 = "<" Or St1 = ">" And Asc(St1) > Or _
Asc(St1) < 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 = To i
St = Mid(ss, j, )
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "" And St1 <= "" Or _
St1 = "℃" Or St1 = "/" And Asc(St1) > Or _
Asc(St1) < 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 = To i
St = Mid(ss, j, )
St1 = UCase(St)
If St1 >= "A" And St1 <= "Z" Or St1 >= "" And St1 <= "" Or _
St1 = "℃" Or St1 = "/" And Asc(St1) > Or _
Asc(St1) < 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 = To Len(ss)
s = Mid(ss, i, )
St1 = UCase(s)
If St1 >= "" And St1 <= "" 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 = To UBound(ss)
e = ""
i = Len(ss(c))
For j = To i
St = Mid(ss(c), j, )
St1 = UCase(St)
If Asc(St1) > Or Asc(St1) < Or St1 = "," Or St1 >= "" And St1 <= "" 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 = To UBound(ss)
e = ""
i = Len(ss(c))
For j = To i
St = Mid(ss(c), j, )
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 = To Len(Value)
s = Mid(Value, i, )
If (Asc(s) > Or Asc(s) > ) 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 = To Len(Value)
s = Mid(Value, i, )
If (s >= "" And s <= "") 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 = To
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 = To
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()
For i = To UBound(l_1day)
If l_1day(i).l_timenow = data Then
OutValue() = "预报时间： " & l_1day(i).l_timenow
OutValue() = "预测当时气温： " & l_1day(i).l_temnow
OutValue() = "预测当时风向风力 " & l_1day(i).l_windstate
OutValue() = "预测当时相对湿度： " & l_1day(i).l_sd
OutValue() = "预测当时天气情况： " & l_1day(i).l_weather
Exit Sub
End If
Next
End Sub
'返回十二时辰列表的日期
Public Function Get_十二时辰_日期$(ByVal Value%)
If Value <= And Value >= Then
Get_十二时辰_日期 = l_1day(Value - ).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 < Then
count = count +
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() = Trim_weatherB(tmpB()): fore_cast_value_1h = Split(tmpB(), ","): fore_cast_default = Split(Trim_weatherB(tmpB()), ",")
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", ""
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 >= Then
GoTo Line2
End If
count = count +
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
Get_生活指数 = l_生活助手.l_data
Case
Get_生活指数 = l_生活助手.l_空调开启指数
Case
Get_生活指数 = l_生活助手.l_过敏指数
Case
Get_生活指数 = l_生活助手.l_晨练指数
Case
Get_生活指数 = l_生活助手.l_舒适度指数
Case
Get_生活指数 = l_生活助手.l_穿衣指数
Case
Get_生活指数 = l_生活助手.l_钓鱼指数
Case
Get_生活指数 = l_生活助手.l_防晒指数
Case
Get_生活指数 = l_生活助手.l_逛街指数
Case
Get_生活指数 = l_生活助手.l_太阳镜指数
Case
Get_生活指数 = l_生活助手.l_感冒指数
Case
Get_生活指数 = l_生活助手.l_划船指数
Case
Get_生活指数 = l_生活助手.l_交通指数
Case
Get_生活指数 = l_生活助手.l_路况指数
Case
Get_生活指数 = l_生活助手.l_晾晒指数
Case
Get_生活指数 = l_生活助手.l_美发指数
Case
Get_生活指数 = l_生活助手.l_夜生活指数
Case
Get_生活指数 = l_生活助手.l_啤酒指数
Case
Get_生活指数 = l_生活助手.l_放风筝指数
Case
Get_生活指数 = l_生活助手.l_空气污染扩散条件指数
Case
Get_生活指数 = l_生活助手.l_化妆指数
Case
Get_生活指数 = l_生活助手.l_旅游指数
Case
Get_生活指数 = l_生活助手.l_紫外线强度指数
Case
Get_生活指数 = l_生活助手.l_风寒指数
Case
Get_生活指数 = l_生活助手.l_洗车指数
Case
Get_生活指数 = l_生活助手.l_心情指数
Case
Get_生活指数 = l_生活助手.l_运动指数
Case
Get_生活指数 = l_生活助手.l_约会指数
Case
Get_生活指数 = l_生活助手.l_雨伞指数
Case
Get_生活指数 = l_生活助手.l_中暑指数
End Select
End Function
Public Function Get_天气信息$(ByVal weather_value As weather_info)
Select Case weather_value
Case
Get_天气信息 = l_weather.l_cityname
Case
Get_天气信息 = l_weather.l_cityid
Case
Get_天气信息 = l_weather.l_weatherstate
Case
Get_天气信息 = l_weather.l_weathere
Case
Get_天气信息 = l_weather.l_tweatherstate
Case
Get_天气信息 = l_weather.l_time
Case
Get_天气信息 = l_weather.l_data
Case
Get_天气信息 = l_weather.l_tem1
Case
Get_天气信息 = l_weather.l_tem2
Case
Get_天气信息 = l_weather.l_temnow
Case
Get_天气信息 = l_weather.l_temfnow
Case
Get_天气信息 = l_weather.l_tsd
Case
Get_天气信息 = l_weather.l_tfl
Case
Get_天气信息 = l_weather.l_sfl
Case
Get_天气信息 = l_weather.l_wse
Case
Get_天气信息 = l_weather.l_qy
Case
Get_天气信息 = l_weather.l_njd
Case
Get_天气信息 = l_weather.l_rain
Case
Get_天气信息 = l_weather.l_sd
Case
Get_天气信息 = l_weather.l_weatherCode
Case
Get_天气信息 = l_weather.l_weathercoded
Case
Get_天气信息 = l_weather.l_weathercoden
Case
Get_天气信息 = l_weather.l_warning_Province
Case
Get_天气信息 = l_weather.l_warning_City
Case
Get_天气信息 = l_weather.l_warning_District
Case
Get_天气信息 = l_weather.l_warning_ID
Case
Get_天气信息 = l_weather.l_warning_Name
Case
Get_天气信息 = l_weather.l_warning_Color_ID
Case
Get_天气信息 = l_weather.l_warning_Color_name
Case
Get_天气信息 = l_weather.l_warning_Time
Case
Get_天气信息 = l_weather.l_warning_Dinfo
Case
Get_天气信息 = l_weather.l_warning_Dinfo_ID
Case
Get_天气信息 = l_weather.l_warning_Dinfo_url
Case
Get_天气信息 = l_weather.l_warning_Date
Case
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() Or valueC = CDbl() 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") +
startB = InStr(Get_precipitation, "times") -
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") + , InStr(Get_weather_lat_lon, "temp") - InStr(Get_weather_lat_lon, "WD") - )
l_weather.l_temnow = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "temp") + , InStr(Get_weather_lat_lon, "weather") - InStr(Get_weather_lat_lon, "temp") - ) & "℃"
l_weather.l_sfl = l_weather.l_sfl & Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "WS") + , InStr(Get_weather_lat_lon, "WD") - InStr(Get_weather_lat_lon, "WS") - )
l_weather.l_sd = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "humidity") + , ) & "%"
l_weather.l_weatherCode = Mid(Get_weather_lat_lon, InStr(Get_weather_lat_lon, "weathercode") + , InStr(Get_weather_lat_lon, "humidity") - InStr(Get_weather_lat_lon, "weathercode") - )
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", ""
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", ""
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) = 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 = 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(), ",")
'__________________________________________
'
'先过一遍城区的数据
Call Get_weather_ID(Left(page_ID, ))
Call station(False, d, )
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", ""
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 = To UBound(jd)
If InStr(jd(i), jdname) <> 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 = Then
Call Set_dataZs_info(Value)
Exit Function
End If
Dim Line_s$, i%
'___________1-3
l_weather.l_tfl = ""
For i = To UBound(Value)
Line_s = Trim_weather(Value(i))
'截取字符串
Select Case mode
Case Is =
Call Set_cityDz_info(Line_s)
Case Is =
Call Set_alrmDz_info(Line_s)
Case Is =
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"), )
town_title = Mid(town_title, InStr(town_title, "title") + , InStr(town_title, "location") - InStr(town_title, "title") - )
'————————————————————气象网的解析
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() & "method" & Chr() & ":" & Chr() & "stationinfo" & Chr() & "," _
& Chr() & "lat" & Chr() & ":" & CStr(lat) & "," _
& Chr() & "lng" & Chr() & ":" & CStr(lon) & "," _
& Chr() & "callback" & Chr() & ":" & Chr() & "getDataGeo" & Chr() & "}": 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") + , InStr(Get_ID_for_lat_lon, "category") - InStr(Get_ID_for_lat_lon, "areaid") - )
'寻找符合节点的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") + , InStr(Get_IP_forCity, Chr() & ";var") - - InStr(Get_IP_forCity, "ip"))
ID = Mid(Get_IP_forCity, InStr(Get_IP_forCity, "id") + , InStr(Get_IP_forCity, Chr() & ";var add") - - InStr(Get_IP_forCity, "id"))
Get_IP_forCity = Mid(Get_IP_forCity, InStrRev(Get_IP_forCity, "=") + , InStrRev(Get_IP_forCity, Chr() & ";") - InStrRev(Get_IP_forCity, "=") - )
'重新组合返回需要的格式 xxx|xxx
Dim i As Byte, tmp$()
tmp = Split(Get_IP_forCity, ",")
Get_IP_forCity = ""
For i = To UBound(tmp)
Get_IP_forCity = Get_IP_forCity & tmp(i)
If i <= (UBound(tmp) - ) 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]
VB6_小林的气象类模块的更多相关文章
- 获取VB类模块成员函数指针(转)
最近在做一些VB6.VBA的项目,被如何获取类模块中的函数指针这个问题所困扰,收集整理后,有2分资料值得收藏,特将关键部分留存,以备后续查找. 参照连接1:http://www.cnblogs.com ...
- ansible笔记（8）：常用模块之系统类模块（二）
ansible笔记():常用模块之系统类模块(二) user模块 user模块可以帮助我们管理远程主机上的用户,比如创建用户.修改用户.删除用户.为用户创建密钥对等操作. 此处我们介绍一些user模块 ...
- ansible笔记（6）：常用模块之命令类模块
ansible笔记():常用模块之命令类模块 command模块 command模块可以帮助我们在远程主机上执行命令 注意:使用command模块在远程主机中执行命令时,不会经过远程主机的shell处 ...
- Python_小林的爬取QQ空间相册图片链接程序
前言 昨天看见某人的空间有上传了XXXX个头像,然后我就想着下载回来[所以本质上这是一个头像下载程序],但是一个个另存为太浪费时间了,上网搜索有没有现成的工具,居然要注册码,还卖45一套.你们的良心也 ...
- VB类模块中属性的参数——VBA中Range对象的Value属性和Value2属性的一点区别
在VB中,属性是可以有参数的,而VBA中属性使用参数非常常见.比如最常用的:Worksheet.Range("A1:A10") VB的语法,使用参数的不一定是方法,也有可能是属性 ...
- VBA标准模块与类模块
大家通过之前的介绍,已知道怎么将一个空模块插入VBA的工程中.从插入模块中可以看到,模块有有两种——标准模块与类模块.类模块是含有类定义的特殊模块,包括其属性和方法的定义.在后面会有介绍与说明. 随着 ...
- VB6/VBA中跟踪鼠标移出窗体控件事件(类模块成员函数指针CHooker类应用)
一.关于起因 前几天发了一篇博文,是关于获取VB类模块成员函数指针的内容(http://www.cnblogs.com/alexywt/p/5880993.html):今天我就发一下我的应用实例. V ...
- ansible笔记（7）：常用模块之系统类模块
ansible笔记():常用模块之系统类模块 cron模块 cron模块可以帮助我们管理远程主机中的计划任务,功能相当于crontab命令. 在了解cron模块的参数之前,先写出一些计划任务的示例,示 ...
- VB-创建类模块DLL文件
最近需要调用MSCOMM32.OCX控件,但是ABAP调用过程中发现无法同时发送多条记录,则需调整实现方式: a.创建DLL文件封装MSCOMM控件相关属性及方法 b.系统注册DLL文件 c.ABAP ...
随机推荐
- django.db.utils.OperationalError: (1050, "Table 'article_category' already exists")
(转自:https://blog.csdn.net/huanhuanq1209/article/details/77884014) 执行manage.py makemigrations 未提示错误信息 ...
- The method setCharacterEncoding(String) is undefined for the type HttpServletResponse
今天将以前做的一个web项目从不笔记本上移到台式机上,import项目后出现“The method setCharacterEncoding(String) is undefined for the ...
- Vue Parent Send Ajax Data to Child Component
Vue 父组件ajax异步更新数据,子组件props获取不到 2018年06月26日 09:25:06 哎哟嘿 阅读数 3585 当父组件 axjos 获取数据,子组件使用 props 接 ...
- spring 定时任务的 执行时间设置规则-----看完这篇就懂了
单纯针对时间的设置规则 org.springframework.scheduling.quartz.CronTriggerBean允许你更精确地控制任务的运行时间,只需要设置其cronExpressi ...
- java微服务简介与实战
今年做了一段时间的可见光.ceph存储,后端开发微服务项目,在这记录点东西,也方便大家借鉴查找. springboot的项目实例:https://github.com/ityouknow/spring ...
- java并发编程--第一章并发编程的挑战
一.java并发编程的挑战 并发编程需要注意的问题: 并发编程的目的是让程序运行的更快,然而并不是启动更多的线程就能让程序最大限度的并发执行.若希望通过多线程并发让程序执行的更快,会受到如下问题的挑战 ...
- Maven的安装和配置（Windows 10）
1. 官网下载Maven管理工具 官网:https://maven.apache.org/download.cgi 系统要求: JDK:Maven 3.3以上需要JDK 1.7以上版本支持 Memor ...
- php学习之Model类
<?php $config = include 'config.php'; //引入数据库配置文件 $model = new Model($config); //测试案例 // $saveDat ...
- linux之i2c子系统维护者源码仓库地址
仓库地址: git://git.kernel.org/pub/scm/linux/kernel/git/wsa/linux.git
- SQL-W3School-高级：SQL FULL JOIN 关键字
ylbtech-SQL-W3School-高级:SQL FULL JOIN 关键字 1.返回顶部 1. SQL FULL JOIN 关键字 只要其中某个表存在匹配,FULL JOIN 关键字就会返回行 ...