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 ...
随机推荐
- 前端知识体系：JavaScript基础-作用域和闭包-闭包的实现原理和作用以及堆栈溢出和内存泄漏原理和相应解决办法
闭包的实现原理和作用 闭包: 有权访问另一个函数作用域中的变量的函数. 创建闭包的常见方式就是,在一个函数中创建另一个函数. 闭包的作用: 访问函数内部变量.保持函数在环境中一直存在,不会被垃圾回收机 ...
- JQuery 实践---创建元素包装集
1. 利用选择器,选择将被JQuery包装的元素 标识和选择DOM元素.JQuery采用我们已经知道的CSS语法并且扩展了一些.为了利用JQuery来选择元素,请把选择器包装在$()中. 基本CSS选 ...
- django获取数据
获取单个值 request.POST.get('user') # user对应前端name属性对应的值 获取多个值(如checkbox,multiple) request.POST.getlist(' ...
- sql server 存储过程和视图的区别
视图 要把视图看做是一张表,包含了一张表的部分数据或者多个表的综合数据,视图的使用和普通表一样: 视图建立并存储在服务器,有效减少网络数据流量,提高安全性: 视图中不存放数据,数据依然存放在视图引用的 ...
- HashMap判断键是否为null
用containsKey(),而不用get(): HashMap中,null可以作为键,这样的键只有一个:可以有一个或多个键所对应的值为null.当get()方法返回null值时,即可以表示HashM ...
- 蓝牙4.0模块，AT指令集
一,LED状态 二,蓝牙模块有两种通信模式 1,AT指令模式 2,数据透传模式 三.AT指令程序设计 1.设置模块的名字 void usart3_send_str(char *pbuf) { whil ...
- Shell基本语法知识
Shell 就是一个命令解释器,他的作用就是解释执行用户输入的命令及程序等,用户每输入一条命令,Shell 就解释一条.这种从键盘一输入命令,就可以立即得到回应的对话方式,就称为交互的方式. 当命令或 ...
- c语言中sprintf()函数中的%使用
#include <stdio.h> #include <string.h> int main() { ] = {}; ] = {}; ] = {}; /*打印2个%*/ st ...
- [报错解决] 关于windows下 使用Anaconda3安装的python无法使用ssl模块问题.关联pip无法下载https
关联错误: pip is configured with locations that require TLS/SSL, however the ssl module in Python is not ...
- CComboBoxEx添加图像CImageList无法正常显示
<1>给控件 CComboBox绑定变量 .cpp中 DDX_Control(pDX, IDC_COMBO_PHOTO_IMG, m_ComboBoxPhotoImg); CComboBo ...