ttaa_mic.txt

气象TTAA1.DAT格式转换为MICAPS格式并计算各种物理量

Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredacess&, ByVal bInherithandle&, ByVal dwProcessid&) As Long
 
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpexitcode As Long) As Long





Private Sub Command2_Click() '资料日期转换
Dim riqi0 As Date
Open App.Path & "\zlriqi0.txt" For Output As 2
Open App.Path & "\zlriqi.txt" For Input As 1

Do While Not EOF(1)
Input #1, riqi
nian = Mid$(Trim$(riqi), 1, 4): yue = Mid$(Trim$(riqi), 5, 2): ri = Mid$(Trim$(riqi), 7, 2)
If yue < 10 Then yue = "0" + Right$(yue, 1)
If ri < 10 Then ri = "0" + Right$(ri, 1)
riqi0 = Right$(nian, 4) + "-" + Right$(yue, 2) + "-" + Right$(ri, 2)

Print #2, Format$(riqi0 - 2, "yyyy") + Format$(riqi0 - 2, "mm") + Format$(riqi0 - 2, "dd") '前两天
Print #2, Format$(riqi0 - 1, "yyyy") + Format$(riqi0 - 1, "mm") + Format$(riqi0 - 1, "dd")  '前一天
Print #2, Format$(riqi0, "yyyy") + Format$(riqi0, "mm") + Format$(riqi0, "dd")           '当天
Print #2, Format$(riqi0 + 1, "yyyy") + Format$(riqi0 + 1, "mm") + Format$(riqi0 + 1, "dd") '后一天

Loop
Close
MsgBox ("资料日期转换完成")
End Sub



Private Sub Form_Load()
For yyyy = 1980 To 2050
  Combo1.AddItem yyyy
  Combo3.AddItem yyyy
Next yyyy
For MM = 1 To 12
  Combo2.AddItem MM
  Combo4.AddItem MM
Next MM

Combo1.Text = 1980
Combo2.Text = 1
Combo3.Text = 2005
Combo4.Text = 12
Check1.Value = 1
Check2.Value = 1
End Sub

Private Sub GKZL_MICAPS_Click()

Caption = "正在计算处理,请稍侯!"
GKZL_MICAPS.MaskColor = RGB(255, 0, 0)

'***************  连续资料处理 **********************
If Option1.Value = True Then Call GKZL_MICAPS00

'***************  不连续资料处理 ********************

If Option2.Value = True Then Call GKZL_MICAPS01

End Sub


Sub GKZL_MICAPS00()

'***************  连续资料处理 ****************************************

Dim DATAFILE As String, SAVEFILE As String
'***********************************************
'      高空原始报文转换为TTAA1.DAT格式
'***********************************************
GKZL_MICAPS.Caption = "正在处理资料，请稍候......"
Dim hShell As Long, hProc As Long, lExit As Long

'************  注意修改资料日期  ******************************
StarYea = Val(Combo1.Text): EndYea = Val(Combo3.Text)
StarMon = Val(Combo2.Text): EndMon = Val(Combo4.Text)
StarDaa = 1: EndDaa = 31
StarTim = 1: EndTim = 2
'*************************************************************
If Check1.Value = 1 And Check2.Value = 1 Then StarTim = 1: EndTim = 2
If Check1.Value = 1 And Check2.Value <> 1 Then StarTim = 1: EndTim = 1
If Check1.Value <> 1 And Check2.Value = 1 Then StarTim = 2: EndTim = 2

For Yea = StarYea To EndYea
For Mon = StarMon To EndMon
For Daa = StarDaa To EndDaa
 For Tim = StarTim To EndTim
  If Mon < 10 Then Mon = "0" + Right$(Mon, 1)
  If Daa < 10 Then Daa = "0" + Right$(Daa, 1)
  If Tim = 1 Then tim0 = "00": TIM1 = "08"
  If Tim = 2 Then tim0 = "12": TIM1 = "20"
  YYMMDDTT = Right$(Yea, 2) + Right$(Mon, 2) + Right$(Daa, 2) + tim0
  
  '************  注意修改资料路径 ******************************
  
    DATAFILE = "D:\TTAA1\data\" + YYMMDDTT + ".TTA"
    
  '*************************************************************
  If Dir(DATAFILE) <> "" Then
   SAVEFILE = "D:\TTAA1\DATA\" + YYMMDDTT + ".DAT"
    TTAA1FILE = "D:\TTAA1\ttaa1.dat"
    'If Dir(TTAA1FILE) <> "" Then Kill TTAA1FILE
   
     Call TTAA_TTAA1(DATAFILE, SAVEFILE)   '转换过程

     FileCopy SAVEFILE, TTAA1FILE

     Open "d:\ttaa1\wsdat.dat" For Output As 15
      Print #15, YYMMDDTT
     Close #15

   filegg = App.Path & "\gg" + Mid$(YYMMDDTT, 5, 2) + tim0 + ".dat"
     If Dir(filegg) <> "" Then Kill filegg

      '*****************************************************
         hShell = Shell("cl00h.bat ", vbMinimizedFocus)

         hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)
          Do
             GetExitCodeProcess hProc, lExit
             DoEvents
          Loop While lExit = STILL_ACTIVE
      '*****************************************************
    ' Print #5, rr, Time
   filegg = App.Path & "\gg" + Mid$(YYMMDDTT, 5, 2) + tim0 + ".dat"
  If Dir(filegg) <> "" Then Kill filegg
  If Dir(SAVEFILE) <> "" Then Kill SAVEFILE
  
  GKZL_MICAPS.Caption = "处理资料的日期:" & YYMMDDTT
  Else
  GKZL_MICAPS.Caption = "处理资料的日期:" & YYMMDDTT & " 缺 ！"
  End If
 Next Tim
Next Daa
Next Mon
Next Yea


GKZL_MICAPS.Caption = "资料处理完成!!!"



End
End Sub


Sub GKZL_MICAPS01()
'***************  不连续资料处理 ****************************************
MousePointer = 11
Dim DATAFILE As String, SAVEFILE As String
'***********************************************
'      高空原始报文转换为TTAA1.DAT格式
'***********************************************
GKZL_MICAPS.Caption = "正在处理资料，请稍候......"
Dim hShell As Long, hProc As Long, lExit As Long

Open "d:\ttaa1\zlriqi0.txt" For Input As 3
Do While Not EOF(3)
Input #3, riqi
StarTim = 1: EndTim = 2

If Check1.Value = 1 And Check2.Value = 1 Then StarTim = 1: EndTim = 2
If Check1.Value = 1 And Check2.Value <> 1 Then StarTim = 1: EndTim = 1
If Check1.Value <> 1 And Check2.Value = 1 Then StarTim = 2: EndTim = 2

 For Tim = StarTim To EndTim
  If Tim = 1 Then tim0 = "00": TIM1 = "08"
  If Tim = 2 Then tim0 = "12": TIM1 = "20"
  YYMMDDTT = Right$(riqi, 6) + tim0
   'DATAFILE = "D:\ttaa1\data\" + YYMMDDTT + ".TTA"
''   DATAFILE = "D:\gkbwzl\data\" + YYMMDDTT + ".TTA"
''   SAVEFILE = "D:\TTAA1\DATA\" + YYMMDDTT + ".DAT"
''    TTAA1FILE = "D:\TTAA1\ttaa1.dat"
''     If Dir(TTAA1FILE) <> "" Then Kill TTAA1FILE
 DATAFILE = "D:\TTAA1\data\" + YYMMDDTT + ".TTA"
    
  '*************************************************************
  If Dir(DATAFILE) <> "" Then
   SAVEFILE = "D:\TTAA1\DATA\" + YYMMDDTT + ".DAT"
    TTAA1FILE = "D:\TTAA1\ttaa1.dat"
     Call TTAA_TTAA1(DATAFILE, SAVEFILE)   '转换过程

     FileCopy SAVEFILE, TTAA1FILE

     Open "d:\ttaa1\wsdat.dat" For Output As 15
      Print #15, YYMMDDTT
     Close #15
     
    'filegg = App.Path & "\gg" + Mid$(YYMMDDTT, 5, 2) + tim0 + ".dat"
    'If Dir(filegg) <> "" Then Kill filegg
      '*****************************************************
         'TTAA1.DAT格式转换为MICAPS格式并计算各种物理量
         hShell = Shell("D:\TTAA1\cl00h.bat ", vbMinimizedFocus)
         hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)
          Do
             GetExitCodeProcess hProc, lExit
             DoEvents
          Loop While lExit = STILL_ACTIVE
      '*****************************************************
   ' filegg = App.Path & "\gg" + Mid$(YYMMDDTT, 5, 2) + tim0 + ".dat"
   ' If Dir(filegg) <> "" Then Kill filegg
   ' If Dir(SAVEFILE) <> "" Then Kill SAVEFILE

  GKZL_MICAPS.Caption = "处理资料的日期:" & YYMMDDTT
  Else
  GKZL_MICAPS.Caption = "处理的日期:" & YYMMDDTT & " 缺 资料！"
  End If
 Next Tim

Loop
Close #3

GKZL_MICAPS.Caption = "资料处理完成!!!"
'***********************************************************************

End
End Sub
Sub TTAA_TTAA1(DATAFILE As String, SAVEFILE As String)
'***************************************************
'  子过程 1   高空原始报文（TTAA）转换为TTAA1格式
'***************************************************
Dim CC(15)
Dim BWCC(15)
Dim BW00(100000)
Dim BBBB(17)
Open SAVEFILE For Output As 12

CC(1) = " 99": CC(2) = " 00": CC(3) = " 92": CC(4) = " 85": CC(5) = " 70"
CC(6) = " 50": CC(7) = " 40": CC(8) = " 30": CC(9) = " 25": CC(10) = " 20"
CC(11) = " 15": CC(12) = " 10": CC(13) = " 88"

If Dir(DATAFILE) <> "" Then
 Open DATAFILE For Input As 10
 Do While Not EOF(10)
 
 Line Input #10, AAAA
 If Mid$(Trim$(AAAA), 1, 4) = "TTAA" And Right$(Trim$(AAAA), 4) <> "NIL=" Then
 '如果是TTAA报文且有内容,则继续下面步骤
 GKSTA = Abs(Val(Mid$(Trim$(AAAA), 13, 5))) '站号
   BW00(GKSTA) = Format$(GKSTA, "00000") '以站号作为数组的标示
 For II = 1 To 13
     BWCC(II) = " ///// ///// /////"
     BBB0 = " /////": BBB1 = " /////": BBB2 = " /////"
     If InStr(AAAA, CC(II)) > 17 And InStr(AAAA, CC(II)) < 30 + (II - 1) * 18 Then
        BWCC(II) = Mid$(Trim$(AAAA), InStr(AAAA, CC(II)), 18)
        
''        For IIII = 1 To 15: BBBB(IIII) = "/": Next IIII
        For IIII = 1 To 17

            BBBB(IIII) = Mid$(Trim$(BWCC(II)), IIII, 1)
            If IsNumeric(BBBB(IIII)) = True Or BBBB(IIII) = " " Then
                BBBB(IIII) = BBBB(IIII)
                Else
                BBBB(IIII) = "/"
            End If
        Next IIII
       BBB0 = " " + Right$(BBBB(1), 1) + Right$(BBBB(2), 1) + Right$(BBBB(3), 1) + Right$(BBBB(4), 1) + Right$(BBBB(5), 1)
       BBB1 = " " + Right$(BBBB(7), 1) + Right$(BBBB(8), 1) + Right$(BBBB(9), 1) + Right$(BBBB(10), 1) + Right$(BBBB(11), 1)
       BBB2 = " " + Right$(BBBB(13), 1) + Right$(BBBB(14), 1) + Right$(BBBB(15), 1) + Right$(BBBB(16), 1) + Right$(BBBB(17), 1)
      BWCC(II) = BBB0 + BBB1 + BBB2
     
     End If
   BW00(GKSTA) = BW00(GKSTA) + BWCC(II)
   
   If Right$(BW00(GKSTA), 1) = "=" Then BW00(GKSTA) = Left$(Trim$(BW00(GKSTA)), Len(Trim$(BW00(GKSTA))) - 1)
   
   
 Next II
 BW00(GKSTA) = BW00(GKSTA) + " ///// ///// ///// ///// "
 
 End If
 Loop
 
 
 End If
 
 
 STAMM = 0
 For KK = 10000 To 70000
  If BW00(KK) <> "" Then STAMM = STAMM + 1    '实际站点数
 Next KK
 
 SHIJIAN = Right$(Trim$(DATAFILE), 12)  'YYMMDDHH.TTA
 Time0 = Mid$(SHIJIAN, 5, 4)
 
    Print #12, "   TTAA TELE NUMBER=" + Str(STAMM) + "   TIME=" + Time0
    Print #12, " "
 For KK = 10000 To 70000
  If BW00(KK) <> "" Then
     Print #12, Mid$(BW00(KK), 1, 66)
     Print #12, Mid$(BW00(KK), 67, 66)
     Print #12, Mid$(BW00(KK), 133, 66)
     Print #12, Mid$(BW00(KK), 199, 66)
     Print #12, "///// ///// ///// ///// ///// ///// ///// /////   0   "
  End If
  Next KK
 
 Close #10
 Close #12

End Sub

Private Sub Option1_Click()
  Option1.Value = True
End Sub

Private Sub Option2_Click()
  Option2.Value = True
End Sub