📄 ganhan.txt
字号:
Private Sub Command1_Click()
Dim wutt() As Long
Dim c1 As Long
Dim rstSQLZB As New ADODB.Recordset
zhanhao = Left(List1.List(List1.ListIndex), 5)
sql = "select (format(rain.nf)+format(rain.yf,'00')+format(rain.rq,'00')) as r_date,rain.rr,zfl.dxzf from rain,zfl where rain.nf=zfl.nf and rain.yf=zfl.yf and rain.rq=zfl.rq and zfl.zh=rain.zh and rain.zh=" + zhanhao + " and zfl.nf>=2002 order by 1"
With rstSQLZB
If .State = adStateOpen Then .Close
.ActiveConnection = cnnSUP
.CursorType = adOpenKeyset
.LockType = adLockBatchOptimistic
.Open sql
.MoveFirst
qsn = CInt(Left(!r_date, 4))
rec = .RecordCount
rray = .GetRows(rec)
.MoveLast
jsn = CInt(Left(!r_date, 4))
.Close
End With
cs1 = 0
cs2 = 0
cs3 = 0
zfl = 0
ghqs = 0
ghzz = 0
' Print #2, List1.List(List1.ListIndex) + "资料起始年:"; qsn, "结束年:"; jsn
For i = 0 To rec - 11
ghqs = 0
ghzz = 0
cs1 = 0
cs2 = 0
cs3 = 0
zfl = 0
q32766 = 0
If CInt(Mid(rray(0, i), 5, 2)) > 4 And CInt(Right(rray(0, i), 4)) < 1121 Then
Do While CInt(Mid(rray(0, i), 5, 2)) > 5 And CInt(Right(rray(0, i), 4)) < 1121
For js = 0 To 9
If i + js > rec - 1 Then Exit Do
If rray(1, i + js) = 32766 Then
q32766 = q32766 + 1
If q32766 >= 2 Then
i = i + 1
Exit Do
End If
End If
If rray(2, i + js) < 32766 Then zfl = zfl + rray(2, i + js) '10天蒸发量
If rray(1, i + js) > 0 And rray(1, i + js) < 32766 Then
cs2 = cs2 + 1 '10天连续雨日数
cs3 = cs3 + rray(1, i + js) '10天降水量
Else
cs2 = 0
End If
Next js
gsd = 0
' If rray(0, i) >= "19510719" Then
' a = cs3
' End If
' If cs3 > 0 Then If CSng(zfl) / cs3 >= 2 Then gsd = 1 '小型 2.67
If cs3 > 0 Then If CSng(zfl) / cs3 >= 1.5 Then gsd = 1 '大型 2
If cs3 = 0 Then gsd = 1
If cs2 <= 4 And gsd = 1 Then
If ghqs = 0 Then
qt = 0
rs = 0
Do While rs < 10
If rray(1, i + rs) = 0 Then '选连晴两天以上的第一个晴日作为始日
qt = qt + 1
Else
qt = 0
End If
If qt = 2 Then
ghqs = rray(0, i + rs - 1) '开始
Exit Do
End If
rs = rs + 1
Loop
End If
Else
qt = 0
rs = 0
Do While rs < 10
If rray(1, i + rs) > 0 Then '选连雨三天以上的前一个晴日作为终日
qt = qt + 1
Else
qt = 0
End If
If qt = 3 Then
ghzz = rray(0, i + rs - 3) '结束
Exit Do
End If
rs = rs + 1
Loop
If ghzz = 0 Then ghzz = rray(0, i - 1)
If ghqs > 0 And CLng(ghqs) < CLng(ghzz) Then
'开始到结束的天数
ts = CDate(Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2)) - CDate(Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2)) + 1
If ts >= 30 Then '超过40 则发生干旱
' If ts >= 90 Then
' '特大干旱
' Print #2, "特大干旱 "; ts, Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2), Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2)
' ElseIf ts >= 60 Then
' '大旱
' Print #2, "大旱 "; ts, Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2), Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2)
'
' Else
' '一般干旱
Print #2, zhanhao; ";"; ts; ";" + Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2); ";" + Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2);
Dim rstSQLZB1 As New ADODB.Recordset
sql = "select (format(nf)+format(yf,'00')+format(rq,'00')) as r_date,th from temp where cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))>=cdate('" + Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2) + "') and cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))<=cdate('" + Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2) + "') and th>=350 and th<32000 and zh=" + zhanhao
With rstSQLZB1
If .State = adStateOpen Then .Close
.ActiveConnection = cnnSUP
.CursorType = adOpenKeyset
.LockType = adLockBatchOptimistic
.Open sql
' .MoveLast
rec1 = .RecordCount
.Close
End With
'Print #2, " 35度："; rec1;
Print #2, ";"; rec1;
sql = "select (format(nf)+format(yf,'00')+format(rq,'00')) as r_date,th from temp where cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))>=cdate('" + Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2) + "') and cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))<=cdate('" + Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2) + "') and th>=380 and th<32000 and zh=" + zhanhao
With rstSQLZB1
If .State = adStateOpen Then .Close
.ActiveConnection = cnnSUP
.CursorType = adOpenKeyset
.LockType = adLockBatchOptimistic
.Open sql
' .MoveLast
rec1 = .RecordCount
.Close
End With
'Print #2, " 38度："; rec1;
Print #2, ";"; rec1;
sql = "select sum(rr) from rain where cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))>=cdate('" + Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2) + "') and cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))<=cdate('" + Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2) + "') and rr<32000 and zh=" + zhanhao
With rstSQLZB1
If .State = adStateOpen Then .Close
.ActiveConnection = cnnSUP
.CursorType = adOpenKeyset
.LockType = adLockBatchOptimistic
.Open sql
' .MoveLast
rec1 = .Fields(0)
.Close
End With
'Print #2, " 总雨量："; rec1 / 10;
Print #2, ";"; rec1 / 10;
sql = "select sum(dxzf) from zfl where cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))>=cdate('" + Left(ghqs, 4) + "-" + Mid(ghqs, 5, 2) + "-" + Right(ghqs, 2) + "') and cdate(format(nf)+'-'+format(yf,'00')+'-'+format(rq,'00'))<=cdate('" + Left(ghzz, 4) + "-" + Mid(ghzz, 5, 2) + "-" + Right(ghzz, 2) + "') and dxzf<32000 and not isnull(dxzf) and zh=" + zhanhao
With rstSQLZB1
If .State = adStateOpen Then .Close
.ActiveConnection = cnnSUP
.CursorType = adOpenKeyset
.LockType = adLockBatchOptimistic
.Open sql
' .MoveLast
rec2 = .Fields(0)
.Close
End With
If rec1 = 0 Then
'Print #2, " 蒸发量："; rec2 / 10; " 蒸发/降水:"; ""
Print #2, ";"; rec2 / 10; ";"; " "
Else
'Print #2, " 蒸发量："; rec2 / 10; " 蒸发/降水:"; Format(rec2 / rec1, "0.00")
Print #2, ";"; rec2 / 10; ";"; Format(rec2 / rec1, "0.00")
End If
' End If
End If
ghqs = 0
ghzz = 0
End If
End If
'初始化 重新搜索
cs1 = 0
cs2 = 0
cs3 = 0
zfl = 0
q32766 = 0
i = i + 1
Loop
End If
Next i
MsgBox "完了"
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -