form1.frm

水文管理信息系统

   Exit Sub
End If

.ChartType = xlXYScatterSmoothNoMarkers ' xlXYScatterSmooth ' xlXYScatterLines ' xlLineMarkers '图表类型
.HasTitle = False

.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).HasTitle = True

  .Axes(xlValue).AxisTitle.Caption = "时间"
If PlotBy(0).Value = True Then
   .Axes(xlCategory).AxisTitle.Caption = "水文"
ElseIf PlotBy(1).Value = True Then
  .Axes(xlCategory).AxisTitle.Caption = "流量"
Else
   MsgBox "请选择数据源"
   Exit Sub
End If


.Legend.Clear
'以下两行设置X轴数据为a(i)

.SeriesCollection(1).Delete
.SeriesCollection(1).XValues = xlsWsNew.Range("Sheet1!$C$" & rStart & ":$C$" & rEnd)

.Location Where:=xlLocationAsNewSheet ', Name:="Sheet2"
End With

xlsApp.DisplayAlerts = False
 ChartxlsWb.SaveAs (App.Path & "\dat\graph.xls")
 OLE1.CreateEmbed App.Path & "\dat\graph.xls", "MSGRAPH"
 ChartxlsWb.Close

End Sub

Private Sub Export_Click()
Dim Exportxlsapp As New Excel.Application
Dim Exportxlswb As Excel.Workbook
Set Exportxlswb = Exportxlsapp.Workbooks.Add


Text3.Text = ""
Text4.Text = ""
Export.Visible = False
ProgressBar1.Visible = True
InfoLabel.Visible = True

ProgressBar1.Value = 1
ProgressBar1.Min = 1
ProgressBar1.Max = 10
 InfoLabel.Caption = ""


 xlsApp.DisplayAlerts = False
For i = 0 To 8
      
        InfoLabel.Refresh
        InfoLabel.Caption = "正在导出EXCEL格式数据:站点" & StationCode(i)

        Exportxlswb.Sheets.Add
        Set xlsWsExport = Exportxlswb.Worksheets(1)
        xlsWsExport.Name = StationCode(i)
        
        xlsWsNew.Select
        xlsWsNew.Range(Cells(RowUbound(i) + 1, 1), Cells(RowUbound(i + 1), 5)).Select
        Selection.Copy
        xlsWsExport.Select
        xlsWsExport.Paste
         
        ProgressBar1.Value = ProgressBar1.Value + 1
        

Next

  
     '复制xlsWsNew
     Exportxlswb.Worksheets.Add
     Set xlsWsExport = Exportxlswb.Worksheets(Exportxlswb.Worksheets.Count)
     xlsWsExport.Name = "Data"
     xlsWsNew.Select
     xlsWsNew.Range(Cells(1, 1), Cells(6000, 5)).Select
     Selection.Copy
     xlsWsExport.Select
     xlsWsExport.Paste
    
 '导出EXCEL
 xlsApp.DisplayAlerts = False
 Exportxlsapp.DisplayAlerts = False
' Exportxlswb.Worksheets("Sheet11").Delete
 Exportxlswb.SaveAs (App.Path & "\导出数据\" & Date & ".xls")
 
 
 ProgressBar1.Value = 1
 ProgressBar1.Min = 1
 ProgressBar1.Max = 10
 InfoLabel.Caption = ""

 '导出txt
 For i = 0 To 8
      InfoLabel.Refresh
      InfoLabel.Caption = "正在导出TXT格式数据:站点" & StationCode(i)
      Exportxlswb.Worksheets(StationCode(i)).Activate
      Exportxlswb.SaveAs App.Path & "\导出数据\" & StationCode(i) & "-" & Date & ".txt", FileFormat:=xlText
      
      ProgressBar1.Value = ProgressBar1.Value + 1
        
        If i = 8 Then
           InfoLabel.Refresh
           InfoLabel.Caption = "数据导出完毕"
        End If
 Next
 
 


 For i = 2 To xlsWb.Sheets.Count
         Exportxlswb.Sheets(i).Delete
 Next
 
 
InfoLabel.Visible = False
Export.Visible = True
ProgressBar1.Visible = False
Exportxlsapp.Quit

End Sub

Private Sub Form_Load()
StationCode(0) = 60001
StationCode(1) = 60002
StationCode(2) = 60004
StationCode(3) = 60012
StationCode(4) = 60013
StationCode(5) = 60025
StationCode(6) = 60814
StationCode(7) = 60815
StationCode(8) = 60816

If Dir(App.Path & "\data.xls", vbNormal) = "" Then
  MsgBox "找不到data.xls文件,请在根目录建data.xls文件！"
  End
End If
  
Set xlsApp = New Excel.Application
Set xlsWb = xlsApp.Workbooks.Open(App.Path & "\data.xls") '要打开的文档路径
Set xlsWs = xlsWb.Worksheets(1)
xlsWb.Sheets.Add

If Dir(App.Path & "\dat", vbDirectory) = "" Then
    MkDir (App.Path & "\dat")
End If

If Dir(App.Path & "\导出数据", vbDirectory) = "" Then
    MkDir (App.Path & "\导出数据")
End If

If Dir(App.Path & "\dat\StationCode.dat", vbNormal) = "" Then
   Open App.Path & "\dat\StationCode.dat" For Output As #1
        For i = 0 To 8
            Print #1, StationCode(i)
        Next
    Close #1
End If


Set xlsWsNew = xlsWb.Worksheets(2)
xlsWs.Select
xlsWs.Range(Cells(1, 1), Cells(60000, 5)).Select
Selection.Copy
xlsWsNew.Select
ActiveSheet.Paste
xlsWsNew.Range(Cells(2, 1), Cells(60000, 5)).Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending


Dim fo As New FileSystemObject
Dim f As File
Set f = fo.GetFile(App.Path & "\data.xls")

If Dir(App.Path & "\dat\RowUbound.dat", vbNormal) <> "" Then
   Open App.Path & "\dat\RowUbound.dat" For Input As #1

   For i = 0 To 10
      Input #1, RowUbound(i)
   Next
   
   For i = 0 To 8
    StationList.AddItem StationCode(i)
    QueryStationList.AddItem StationCode(i)
   Next
   
  Close #1
   If RowUbound(10) <> f.DateLastModified Then
       ExportRowUbound
   End If
      
Else

   ExportRowUbound
  Open App.Path & "\dat\RowUbound.dat" For Input As #1

   For i = 0 To 10
      Input #1, RowUbound(i)
   Next
   For i = 0 To 8
    StationList.AddItem StationCode(i)
   Next
   
   Close #1
End If

End Sub


Private Sub Query_Click()
Dim station As String
Dim time As String

station = QueryStationList.Text
time = QueryTimeList.Text

Text3.Text = ""
Text4.Text = ""
index = QueryStationList.ListIndex
 
If QueryStationList.Text = "" Then
    MsgBox "请选择站点!", vbCritical
    Exit Sub
ElseIf QueryTimeList.Text = "" Then
    MsgBox "请选择时间!", vbCritical
    Exit Sub
End If


  For i = RowUbound(index) + 1 To RowUbound(index + 1)
     If xlsWsNew.Cells(i, 2) <> "" And xlsWsNew.Cells(i, 2) = station And xlsWsNew.Cells(i, 3) = time Then
         Text3.Text = Text3.Text & xlsWsNew.Cells(i, 4) & vbCrLf
         Text4.Text = Text4.Text & xlsWsNew.Cells(i, 5) & vbCrLf
    End If
  Next
  

End Sub

Private Sub Form_Unload(Cancel As Integer)
       xlsApp.DisplayAlerts = False
       xlsWb.Close
       xlsApp.Quit
       Set xlsApp = Nothing
       End
End Sub

Public Function ExportRowUbound()
Dim fo As New FileSystemObject
Dim f As File
Set f = fo.GetFile(App.Path & "\data.xls")

Form2.Show

Open App.Path & "/dat/RowUbound.dat" For Output As #1
If xlsWsNew.Cells(2, 2) <> "" And CDbl(xlsWsNew.Cells(2, 2)) > 60000 Then
   RowUbound(0) = 2
Else
   For j = 2 To 1000
        If xlsWsNew.Cells(j, 2) <> 60001 And xlsWsNew.Cells(j + 1, 2) = 60001 Then
          RowUbound(0) = j
          Exit For
        End If
   Next
End If

Form2.InfoLabel.Caption = "数据更新中..."
Form2.ProgressBar1.Value = 1
Form2.ProgressBar1.Min = 1
Form2.ProgressBar1.Max = 10
k = 1
For j = 2 To 60000
    If xlsWsNew.Cells(j, 2) <> "" And CDbl(xlsWsNew.Cells(j, 2)) > 60000 And xlsWsNew.Cells(j, 2) <> xlsWsNew.Cells(j + 1, 2) Then
            RowUbound(k) = j
            k = k + 1
            Form2.ProgressBar1.Value = Form2.ProgressBar1.Value + 1
    ElseIf xlsWs.Cells(j, 2) = "" Then
           Exit For
    End If
Next


For i = 0 To 9
    Print #1, RowUbound(i)
Next

Print #1, f.DateLastModified
Close #1

Form2.Hide
Form2.Visible = False
Form1.Show
End Function
Private Sub QueryStationList_Click()

QueryTimeList.Clear
rStart = RowUbound(QueryStationList.ListIndex) + 1
rEnd = RowUbound(QueryStationList.ListIndex + 1)

For i = rStart To rEnd
    QueryTimeList.AddItem xlsWsNew.Cells(i, 3)
    
Next

End Sub