form1.frm

vb中excel编程

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