dia.frm

实现GPS RTK测量成果的自动同点名均值输出

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form dia 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "RTK成果转换   编程：李冰 2007.10.24"
   ClientHeight    =   2460
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   6030
   Icon            =   "dia.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   2460
   ScaleWidth      =   6030
   StartUpPosition =   1  '所有者中心
   Begin VB.CheckBox chktx 
      Caption         =   "不要天线高"
      Height          =   255
      Left            =   360
      TabIndex        =   6
      Top             =   1320
      Width           =   1215
   End
   Begin VB.CommandButton cmdrun 
      Caption         =   "转换"
      Height          =   375
      Left            =   1800
      TabIndex        =   5
      Top             =   1680
      Width           =   735
   End
   Begin VB.CommandButton cmdview 
      Caption         =   "浏览"
      Default         =   -1  'True
      Height          =   375
      Left            =   5160
      TabIndex        =   4
      Top             =   600
      Width           =   735
   End
   Begin VB.TextBox txtfilename 
      BackColor       =   &H80000018&
      ForeColor       =   &H8000000D&
      Height          =   615
      Left            =   240
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   1  'Horizontal
      TabIndex        =   2
      Top             =   600
      Width           =   4695
   End
   Begin MSComDlg.CommonDialog dia 
      Left            =   120
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton CancelButton 
      Caption         =   "清空"
      Enabled         =   0   'False
      Height          =   375
      Left            =   2760
      TabIndex        =   1
      Top             =   1680
      Width           =   735
   End
   Begin VB.CommandButton OKButton 
      Caption         =   "关闭"
      Height          =   375
      Left            =   5160
      TabIndex        =   0
      Top             =   1080
      Width           =   735
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "(格式：点名,X,Y,H,仪器高)"
      ForeColor       =   &H00404040&
      Height          =   180
      Left            =   1440
      TabIndex        =   9
      Top             =   240
      Width           =   2250
   End
   Begin VB.Label Label3 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Caption         =   "-★- 济南军测"
      ForeColor       =   &H00800000&
      Height          =   180
      Left            =   4560
      TabIndex        =   8
      Top             =   1680
      Width           =   1170
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "-★- 任俊专用版 1.5"
      ForeColor       =   &H00000080&
      Height          =   180
      Left            =   3960
      TabIndex        =   7
      Top             =   2040
      Width           =   1710
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "RTK文件名："
      Height          =   180
      Left            =   240
      TabIndex        =   3
      Top             =   240
      Width           =   990
   End
End
Attribute VB_Name = "dia"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Private Sub CancelButton_Click()
    txtfilename.Text = ""
    CancelButton.Enabled = False
    
End Sub

Private Sub cmdrun_Click()
    Dim filename, dm, dm1 As String
    Dim x, x1, y, y1, h, h1, yqg, yqg1, fileopen As Double
    Dim num As Integer
    Dim zhfile, wenti As String
    
    filename = Trim(txtfilename.Text)
    
    If filename = "" Then Exit Sub
    Open filename For Append As #1
      If LOF(1) = 0 Then
        Close #1
        MsgBox "文件不存在或无内容！", 32 + vbOKOnly, "提示："
        Exit Sub
      End If
    Close #1
  
    zhfile = Mid(filename, 1, Len(filename) - 4) & "-RTK成果" & ".txt"
    
    Open zhfile For Append As #2
    If LOF(2) <> 0 Then
      wenti = MsgBox("文件" & zhfile & "已存在，是否覆盖？", vbYesNoCancel + vbQuestion + vbDefaultButton1, "问题：")
      If wenti = vbCancel Then
        Close #2
        Exit Sub
      ElseIf wenti = vbNo Then
        With dia
        .Filter = "RTK文件 *.txt|*.txt|所有文件 *.*|*.*"
        .filename = ""
        .ShowSave
        End With
        zhfile = dia.filename
        If Trim(zhfile) = "" Then Close #2: Exit Sub
      End If
    End If
    Close #2
    
    num = 1
    x1 = 0
    y1 = 0
    h1 = 0
    yqg1 = 0
    
  Open filename For Input As #1
    If LOF(1) <> 0 Then
        Input #1, dm1:    If EOF(1) Then Close #1: MsgBox "RTK文件格式错误！", vbOKOnly + vbCritical: Exit Sub
    End If
  Close #1
      
  Open filename For Input As #1
  Open zhfile For Output As #2
  
    If chktx.Value = 0 Then Print #2, "点名", "X", "Y", "H", "仪器高"
    If chktx.Value = 1 Then Print #2, "点名", "X", "Y", "H"

    Do
        Input #1, dm:     If EOF(1) Or Trim(dm) = "" Then Exit Do 'GoTo line1
        Input #1, x:      If EOF(1) Then Exit Do 'GoTo line1
        Input #1, y:      If EOF(1) Then Exit Do 'GoTo line1
        Input #1, h:      If EOF(1) Then Exit Do 'GoTo line1
        Input #1, yqg:    'If EOF(1) Then Exit Do 'GoTo line1
        
        
        If dm1 <> dm Then
            x1 = Format$(x1 / (num - 1), "#0.000")
            y1 = Format$(y1 / (num - 1), "#0.000")
            h1 = Format$(h1 / (num - 1), "#0.00")
            yqg1 = Format$(yqg1 / (num - 1), "#0.000")
            If chktx.Value = 0 Then Print #2, dm1, x1, y1, h1, yqg1
            If chktx.Value = 1 Then Print #2, dm1, x1, y1, h1
            num = 1
            x1 = 0
            y1 = 0
            h1 = 0
            yqg1 = 0
            dm1 = dm
        End If
        x1 = x1 + x
        y1 = y1 + y
        h1 = h1 + h
        yqg1 = yqg1 + yqg
        dm1 = dm
        num = num + 1
        
    Loop Until EOF(1)

        x1 = Format$(x1 / (num - 1), "#0.000")
        y1 = Format$(y1 / (num - 1), "#0.000")
        h1 = Format$(h1 / (num - 1), "#0.00")
        yqg1 = Format$(yqg1 / (num - 1), "#0.000")
        If chktx.Value = 0 Then Print #2, dm1, x1, y1, h1, yqg1
        If chktx.Value = 1 Then Print #2, dm1, x1, y1, h1
  Close #1
  Close #2
  
  wenti = MsgBox("转换完毕，保存在文件：" & zhfile & " 中" & Chr(13) & Chr(13) & "是否打开查看内容？", vbInformation + vbYesNo + vbDefaultButton1, "提示：")
  
  If wenti = vbYes Then
    fileopen = Shell("notepad.exe " & zhfile, vbNormalFocus)
  End If
   
End Sub

Private Sub cmdview_Click()
    With dia
        .Filter = "RTK文件 *.txt|*.txt|所有文件 *.*|*.*"
        .filename = ""
        .ShowOpen
    End With
    
    txtfilename.Text = dia.filename
    If Trim(dia.filename) <> "" Then
      CancelButton.Enabled = True
    End If
End Sub

Private Sub OKButton_Click()
    Unload Me
End Sub