VERSION 5.00
Begin VB.Form FrmTQ 
   Caption         =   "自動站月簡表V1.0 soft666.com/bbs"
   ClientHeight    =   2310
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4950
   DrawWidth       =   2
   Icon            =   "Form1.frx":0000
   MaxButton       =   0   'False
   ScaleHeight     =   2310
   ScaleWidth      =   4950
   Begin VB.Frame Frame1 
      Caption         =   "當月B文件完整路徑"
      Height          =   855
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   4695
      Begin VB.TextBox TxtPath 
         BeginProperty Font 
            Name            =   "宋體"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   180
         TabIndex        =   2
         Text            =   "D:\AWSNET\BaseData\B57845"
         Top             =   300
         Width           =   4335
      End
   End
   Begin VB.CommandButton CmdOK 
      Caption         =   "提取數據形成Excel文檔"
      BeginProperty Font 
         Name            =   "宋體"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   555
      Left            =   120
      TabIndex        =   0
      Top             =   1200
      Width           =   4695
   End
   Begin VB.Label LblInfo 
      Height          =   435
      Left            =   120
      TabIndex        =   3
      Top             =   1800
      Width           =   4575
   End
End
Attribute VB_Name = "FrmTQ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Function IsLeapYearA(ByVal yr As Integer) As Boolean
'判斷一個年份是否為閏年
If ((yr Mod 4) = 0) Then
IsLeapYearA = ((yr Mod 100) > 0) Or ((yr Mod 400) = 0)
End If
End Function

Private Sub CmdOK_Click()
On Error GoTo Err1
LblInfo = ""
Dim IntMM As Integer '當月有多少天
Dim IntYY As Integer
Dim StrMM As String
StrMM = Left(Right(TxtPath, 6), 2)
If Val(Right(TxtPath, 3)) <= 0 And Right(TxtPath, 3) <> "000" Then
    MsgBox "錯誤的B文件名，請輸入包含完整路徑的B文件名", vbCritical, "B文件名錯誤"
    Exit Sub
ElseIf Dir$(TxtPath) = "" Then
    MsgBox "B文件不存在！請輸入包含完整路徑的B文件名", vbCritical, "錯誤"
    Exit Sub
End If

If Len(App.Path) > 3 Then
    If Dir$(App.Path & "\" & "ZDZJianBiao.xls") = "" Then
        MsgBox "找不到程序目錄下的Excel模板文件ZDZJianBiao.xls", vbCritical, "錯誤"
        Exit Sub
    End If
Else
    If Dir$(App.Path & "ZDZJianBiao.xls") = "" Then
        MsgBox "找不到程序目錄下的Excel模板文件ZDZJianBiao.xls", vbCritical, "錯誤"
        Exit Sub
    End If
End If

If Val(Right(TxtPath, 3)) < 900 Then IntYY = "2" & Right(TxtPath, 3) _
    Else IntYY = "1" & Right(TxtPath, 3)
If StrMM = "01" Or StrMM = "03" Or _
    StrMM = "05" Or StrMM = "07" Or _
    StrMM = "08" Or StrMM = "10" Or _
    StrMM = "12" Then
    IntMM = 31
ElseIf StrMM = "04" Or StrMM = "06" Or _
    StrMM = "09" Or StrMM = "11" Then
    IntMM = 30
ElseIf StrMM = "02" Then
    If IsLeapYearA(1900) = False Then IntMM = 28 Else IntMM = 29
Else
    MsgBox "錯誤的B文件名，請輸入包含完整路徑的B文件名", vbCritical, "B文件名錯誤"
    Exit Sub
End If

Dim exl As New Excel.Application
Dim book As New Excel.Workbook
Dim sheet As New Excel.Worksheet
If Len(App.Path) > 3 Then
    Set book = exl.Workbooks.Open(App.Path & "\" & "ZDZJianBiao.xls")
    Set sheet = book.Worksheets(1)
Else
    Set book = exl.Workbooks.Open(App.Path & "ZDZJianBiao.xls")
    Set sheet = book.Worksheets(1)
End If

LblInfo = "請稍候..."
Me.MousePointer = 11
'ZDZJianBiao.xls為模板文件，一般不要更改此文件內容，特別不要刪除行數，否則可能出現計算錯誤
''操作B文件（MDB文件）
Dim Mytmp As Integer '用于存放臨時數據
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(TxtPath)
Set rs = db.OpenRecordset("tabPrimObservData1")
Set rs = db.OpenRecordset("SELECT * FROM tabPrimObservData1")
rs.MoveFirst
'rs.Fields("DryBulbTemp") ''干球
'RelHumidity ''相對濕度
'PrecipitationAmount ''降水量（2、8、14、20分別指過去6小時降水量）
'WindDirect ''風向
'WindVelocity''風速
'''tab4
'DailyMaxTemp ''日最高
'DailyMinTemp ''日最低
'DailyMinRelHumidity 日最小相對濕度''
sheet.Range("A2") = IntMM ''當月天數，在模板中隱藏
Dim R2 As String, R14 As String
Dim T2 As Integer, T8 As Integer, T14 As Integer, T20 As Integer, Tmax As Integer, Tmin As Index
Do Until rs.EOF
    If rs.Fields("ObservTimes") Like IntYY & StrMM & "*" Then  ' 2004040101 2004040102
        'Debug.Print rs.Fields("DryBulbTemp")
        If Right(rs.Fields("ObservTimes"), 2) = "02" Then
            If T2 <> 10 And T2 <> 21 Then
                sheet.Cells(4 + T2, 2) = Val(rs.Fields("DryBulbTemp")) 'DryBulbTemp''干球
                sheet.Cells(4 + T2, 10) = Val(rs.Fields("RelHumidity")) 'RelHumidity ''相對濕度
                sheet.Cells(4 + T2, 20) = rs.Fields("WindDirect") ''WindDirect ''風向
                sheet.Cells(4 + T2, 21) = Val(rs.Fields("WindVelocity")) ''WindVelocity''風速
                R2 = rs.Fields("PrecipitationAmount") ''PrecipitationAmount ''降水量
            End If
            T2 = T2 + 1
            If T2 = 10 Then T2 = 11
            If T2 = 21 Then T2 = 22
        ElseIf Right(rs.Fields("ObservTimes"), 2) = "08" Then
            If T8 <> 10 And T8 <> 21 Then
                sheet.Cells(4 + T8, 3) = Val(rs.Fields("DryBulbTemp"))
                sheet.Cells(4 + T8, 11) = Val(rs.Fields("RelHumidity")) 'RelHumidity ''相對濕度
                sheet.Cells(4 + T8, 22) = rs.Fields("WindDirect") ''WindDirect ''風向
                sheet.Cells(4 + T8, 23) = Val(rs.Fields("WindVelocity")) ''WindVelocity''風速
                If Val(R2) > 0 Or Val(rs.Fields("PrecipitationAmount")) > 0 Then
                    sheet.Cells(4 + T8, 17) = Val(R2) + Val(rs.Fields("PrecipitationAmount")) ''20-8=2+8
                ElseIf R2 = "00" Or rs.Fields("PrecipitationAmount") = "00" Then
                    sheet.Cells(4 + T8, 17) = 0
                Else
                    sheet.Cells(4 + T8, 17) = ""
                End If
            End If
            T8 = T8 + 1
            If T8 = 10 Then T8 = 11
            If T8 = 21 Then T8 = 22
        ElseIf Right(rs.Fields("ObservTimes"), 2) = "14" Then
            If T14 <> 10 And T14 <> 21 Then
                sheet.Cells(4 + T14, 4) = Val(rs.Fields("DryBulbTemp"))
                sheet.Cells(4 + T14, 12) = Val(rs.Fields("RelHumidity")) 'RelHumidity ''相對濕度
                sheet.Cells(4 + T14, 24) = rs.Fields("WindDirect") ''WindDirect ''風向
                sheet.Cells(4 + T14, 25) = Val(rs.Fields("WindVelocity")) ''WindVelocity''風速
                R14 = rs.Fields("PrecipitationAmount") ''PrecipitationAmount ''降水量
            End If
            T14 = T14 + 1
            If T14 = 10 Then T14 = 11
            If T14 = 21 Then T14 = 22
        ElseIf Right(rs.Fields("ObservTimes"), 2) = "20" Then
            If T20 <> 10 And T20 <> 21 Then
                sheet.Cells(4 + T20, 5) = Val(rs.Fields("DryBulbTemp"))
                sheet.Cells(4 + T20, 13) = Val(rs.Fields("RelHumidity")) 'RelHumidity ''相對濕度
                sheet.Cells(4 + T20, 26) = rs.Fields("WindDirect") ''WindDirect ''風向
                sheet.Cells(4 + T20, 27) = Val(rs.Fields("WindVelocity")) ''WindVelocity''風速
                sheet.Cells(4 + T20, 18) = Val(R14) + Val(rs.Fields("PrecipitationAmount")) ''20-8=2+8
                If sheet.Cells(4 + T20, 18) = 0 Then sheet.Cells(4 + T20, 18) = ""
                If Val(R14) > 0 Or Val(rs.Fields("PrecipitationAmount")) > 0 Then
                    sheet.Cells(4 + T20, 18) = Val(R14) + Val(rs.Fields("PrecipitationAmount")) ''20-8=2+8
                ElseIf R14 = "00" Or rs.Fields("PrecipitationAmount") = "00" Then
                    sheet.Cells(4 + T20, 18) = 0
                Else
                    sheet.Cells(4 + T20, 18) = ""
                End If
                
            End If
            T20 = T20 + 1
            If T20 = 10 Then T20 = 11
            If T20 = 21 Then T20 = 22
        End If
        rs.MoveNext
    Else
        rs.MoveNext
    End If
Loop


Set rs = db.OpenRecordset("tabPrimObservData4")
Set rs = db.OpenRecordset("SELECT * FROM tabPrimObservData4")
rs.MoveFirst
'''tab4
'DailyMaxTemp ''日最高
'DailyMinTemp ''日最低
'DailyMinRelHumidity 日最小相對濕度''
T2 = 0
Do Until rs.EOF
    If rs.Fields("RecordDate") Like IntYY & StrMM & "*" Then  ' 20040401
        'Debug.Print rs.Fields("DryBulbTemp")
        If T2 <> 10 And T2 <> 21 Then
            sheet.Cells(4 + T2, 8) = Val(rs.Fields("DailyMaxTemp")) 'DailyMaxTemp ''日最高
            sheet.Cells(4 + T2, 9) = Val(rs.Fields("DailyMinTemp")) 'DailyMinTemp ''日最低
            sheet.Cells(4 + T2, 16) = Val(rs.Fields("DailyMinRelHumidity")) 'DailyMinRelHumidity 日最小相對濕度
        End If
        T2 = T2 + 1
        If T2 = 10 Then T2 = 11
        If T2 = 21 Then T2 = 22
        rs.MoveNext
    Else
        rs.MoveNext
    End If
Loop
db.Close ''關閉MDB

't2 = 33 ''31天
't2=31''29
't2=30''28
If T2 = 32 Then
    sheet.Range("A36:AC36") = ""
ElseIf T2 = 31 Then
    sheet.Range("A35:AC36") = ""
ElseIf T2 = 30 Then
    sheet.Range("A34:AC36") = ""
End If
sheet.Range("A1") = "通道縣氣象局" & IntYY & "年" & StrMM & "月逐日要素"

'exl.Visible = True
If Len(App.Path) > 3 Then
    If Dir(App.Path & "\" & IntYY & StrMM & ".xls") <> "" Then Kill App.Path & "\" & IntYY & StrMM & ".xls"
    book.SaveAs App.Path & "\" & IntYY & StrMM & ".xls"
Else
    If Dir(App.Path & IntYY & StrMM & ".xls") <> "" Then Kill App.Path & IntYY & StrMM & ".xls"
    book.SaveAs App.Path & IntYY & StrMM & ".xls"
End If
book.Close
Set book = Nothing
exl.Quit
Set exl = Nothing
LblInfo = "已完成，保存在" & App.Path & "\" & IntYY & StrMM & ".xls"
Me.MousePointer = 0
Exit Sub

Err1:
LblInfo = ""
Me.MousePointer = 0
book.Close
Set book = Nothing
exl.Quit
Set exl = Nothing
Me.MousePointer = 0
If Err.Number = 75 Then
    MsgBox Err.Description & Chr(13) & "請先關閉已打開的Excel文檔再生成", vbCritical, "出現錯誤，錯誤號" & Err.Number
ElseIf Err.Number = 1004 Then
    MsgBox Err.Description & Chr(13) & "未選擇覆蓋已有文件，取消導出！", vbCritical, "出現錯誤，錯誤號" & Err.Number
Else
    MsgBox Err.Description, vbCritical, "出現錯誤，錯誤號" & Err.Number
End If
End Sub

Private Sub Form_Load()
If Month(Now) <> 1 Then TxtPath = TxtPath & Format(Month(Now) - 1, "00") & "." & Right(Year(Now), 3) _
    Else: TxtPath = TxtPath & Format(Month(Now), "00") & "." & Right(Year(Now), 3)
Me.Show
End Sub