pyppeo.frm

全站仪学习测量与自动测量程序,测量数据excel导出.

         Left            =   5520
         TabIndex        =   3
         Text            =   "Text2"
         Top             =   240
         Width           =   1665
      End
      Begin VB.Label Label2 
         Caption         =   "请输入学习测点："
         Height          =   315
         Left            =   3900
         TabIndex        =   2
         Top             =   270
         Width           =   1935
      End
      Begin VB.Label Label1 
         Caption         =   "站点名称："
         Height          =   345
         Left            =   120
         TabIndex        =   1
         Top             =   300
         Width           =   975
      End
   End
End
Attribute VB_Name = "pyppeo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Public connstr As String
Dim ComPort As Long ' RS232 port number
Dim OnlyAngle As TMC_HZ_V_ANG ' angle data
Dim dSlopeDistance As Double  ' slope distance data
Dim Result As Long


Private Sub Command1_Click()
'添加点
sitename = Combo1.Text
cldotname = Trim(Text2.Text)
If Len(sitename) = 0 Then
  MsgBox "站点名称未输入！"
  Exit Sub
  End If
If Len(cldotname) = 0 Then
  MsgBox "测点名称未输入！"
  Exit Sub
  End If
 sqltxt = "select * from cl_data_study where 站点='" & sitename & "' and 测点='" & cldotname & "'"
 Dim cnn As ADODB.Connection
 Dim rst As ADODB.Recordset
 Set cnn = New ADODB.Connection
 cnn.Open connstr
 Set rst = New ADODB.Recordset
 rst.Open Trim$(sqltxt), cnn, adOpenKeyset, adLockOptimistic
 recnum = rst.RecordCount
 Set rst = Nothing
 Set cnn = Nothing
 
 If recnum < 1 Then
  Adodc1.Recordset.AddNew
  Adodc1.Recordset("站点").Value = sitename
  Adodc1.Recordset("测点").Value = cldotname
  Adodc1.Recordset("创建时间").Value = Now()
  Adodc1.Recordset("零方向").Value = 0
  Adodc1.Recordset.Update
  MsgBox "添加测点成功！"
 Else
  MsgBox "此点已添加过一次！"
  Exit Sub
 End If
 
Adodc1.ConnectionString = connstr
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from cl_data_study where 站点='" & sitename & "'"
Adodc1.Refresh
End Sub

Private Sub Command2_Click()
   Dim s_hz As Double
   Dim s_v As Double
   Dim s_d As Double
   Dim onoff As Long
   
   '判断是否连接
   If Not bApplRunning Then
     MsgBox "还未连接！"
     Exit Sub
   End If
   '判断是否选择了观测点
   If Adodc1.Recordset.EOF Or Adodc1.Recordset.BOF Then
      MsgBox "没有选择测点！"
      Exit Sub
   End If
   '取当前测站和测点
      sitename = Adodc1.Recordset("站点").Value
      cldotname = Adodc1.Recordset("测点").Value
      
'开始测量
'--------------------------------------------
'（1）精瞄
    Result = VB_AUT_GetATRStatus(onoff)
    If Not Result = RC_OK Then
      MsgBox "取不到设备状态"
      Exit Sub
    End If
    If onoff = 0 Then
     Result = VB_AUT_SetATRStatus(1)
    End If
    Result = VB_AUT_FineAdjust3(0.08, 0.08, False)
    If Result <> RC_OK Then
      MsgBox "精瞄失败！"
      Exit Sub
    End If

'（2）执行测距操作。
    Call VB_TMC_SetEdmMode(0)
    Result = VB_TMC_DoMeasure(TMC_DEF_DIST, TMC_AUTO_INC)
    If Not Result = RC_OK Then
      Call VB_TMC_DoMeasure(TMC_CLEAR, TMC_AUTO_INC)
      'ViewError Result
      MsgBox "执行测距操作失败!"
      Exit Sub
    End If

'（3）获取角度（水平角、竖直角）和距离
    Result = VB_TMC_GetSimpleMea(3000, OnlyAngle, dSlopeDistance, TMC_PLANE_INC)
    If Result = RC_OK Or Result = TMC_NO_FULL_CORRECTION Or Result = TMC_ACCURACY_GUARANTEE Then
       s_hz = OnlyAngle.dHz
       s_v = OnlyAngle.dV
       s_d = dSlopeDistance
    Else
        Call VB_TMC_DoMeasure(TMC_CLEAR, TMC_AUTO_INC)
       'ViewError Result
        MsgBox "执行测距操作失败!"
    End If

'（4）数据写入数据库
   Adodc1.Recordset("水平角").Value = s_hz
   Adodc1.Recordset("竖直角").Value = s_v
   Adodc1.Recordset("斜距").Value = s_d
   Adodc1.Recordset("测量时间").Value = Now()
   Adodc1.Recordset.Update

'----------------------
'测量结束
    Call VB_TMC_DoMeasure(TMC_CLEAR, TMC_AUTO_INC)
 
 
End Sub

Private Sub Command3_Click()
'删除当前点
Dim msgstr As String
Dim mrc As ADODB.Recordset
 If (Not Adodc1.Recordset.EOF) And (Not Adodc1.Recordset.BOF) Then
  sitename = Adodc1.Recordset("站点").Value
  cldotname = Adodc1.Recordset("测点").Value
  'sqlstr = "delete cl_data_study  where 站点='" & sitename & "' and 测点='" & cldotname & "'"
  'Set mrc = ExecuteSQL(sqlstr, msgstr)
  'Set mrc = Nothing
  Adodc1.Recordset.Delete
  Adodc1.Refresh
  
 End If
 
Adodc1.ConnectionString = connstr
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from cl_data_study where 站点='" & sitename & "'"
Adodc1.Refresh

End Sub

Private Sub Command4_Click()

 '断开连接
 ' Only if application is running
If bApplRunning Then
  'Abort flag for main measure loop
  bApplRunning = False
  Me.Caption = "学习测量--未连接"
  ' stop running measurements and clear distance data
  Call VB_TMC_DoMeasure(TMC_CLEAR, TMC_AUTO_INC)
  
  'terminate comunication with instr
  Result = VB_COM_CloseConnection()
  If Result <> RC_OK Then
    ' Display error message
    ViewError Result
  End If
  'reinitialize comunication package
  Call VB_COM_End
End If
Unload Me
End Sub

Private Sub Command5_Click()
'设置当前点为零方向
Dim msgstr As String
Dim mrc As ADODB.Recordset
 If (Not Adodc1.Recordset.EOF) And (Not Adodc1.Recordset.BOF) Then
  sitename = Adodc1.Recordset("站点").Value
  cldotname = Adodc1.Recordset("测点").Value
 
  sqlstr = "update cl_data_study set 零方向=0 where 站点='" & sitename & "' and 测点<>'" & cldotname & "'"
  Set mrc = ExecuteSQL(sqlstr, msgstr)
  sqlstr = "update cl_data_study set 零方向=1 where 站点='" & sitename & "' and 测点='" & cldotname & "'"
  Set mrc = ExecuteSQL(sqlstr, msgstr)
  
  Adodc1.Refresh
  End If
  
End Sub

Private Sub Command6_Click()
'显示站点下的所有点
Dim sitename As String
sitename = Combo1.Text
p_sitename = Combo1.Text
Adodc1.ConnectionString = connstr
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from cl_data_study where 站点='" & sitename & "'"
Adodc1.Refresh
End Sub

Private Sub Command7_Click()
  '连接机器人
 If Not bApplRunning Then
    Result = VB_COM_Init()
    If Result = RC_OK Then
      Result = VB_COM_OpenConnection(ComPort, COM_BAUD_9600, 1)
      If Result = RC_OK Then
         bApplRunning = True
         Me.Caption = "学习测量--已连接"
      Else
         ViewError Result
         Call VB_COM_End
      End If
    Else
      ViewError Result
    End If
 Else
  MsgBox "已联接"
 End If
End Sub

Private Sub Command8_Click()
 '断开连接
 ' Only if application is running
If bApplRunning Then
  'Abort flag for main measure loop
  bApplRunning = False
  Me.Caption = "学习测量--未连接"
  ' stop running measurements and clear distance data
  Call VB_TMC_DoMeasure(TMC_CLEAR, TMC_AUTO_INC)
  
  'terminate comunication with instr
  Result = VB_COM_CloseConnection()
  If Result <> RC_OK Then
    ' Display error message
    ViewError Result
  End If
  'reinitialize comunication package
  Call VB_COM_End
End If


 
End Sub

Private Sub Form_Load()
ComPort = COM_1
bApplRunning = False
Me.Caption = "学习测量--未连接"
'在combo1显示站名
 Dim mrc As ADODB.Recordset
 Dim msgtxt As String
 sqltxt = "select 站名 from site_data order by 创建时间 desc"
 msgtxt = ""
 Set mrc = ExecuteSQL(sqltxt, msgtxt)
 Combo1.Clear
 For i = 1 To mrc.RecordCount
   Combo1.AddItem mrc("站名").Value
   mrc.MoveNext
 Next i
 If mrc.RecordCount > 0 Then
   Combo1.ListIndex = 0
 End If

'在combo1显示站名结束
Text2.Text = ""


p_sitename = Combo1.Text
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\pyppeo.mdb;Persist Security Info=False"
Adodc1.ConnectionString = connstr
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from cl_data_study where 站点='" & p_sitename & "'"
Adodc1.Refresh
End Sub

' Function displayed the various error messages
Public Sub ViewError(ByVal Result As Integer)

' display error message
   Call VB_COM_ViewError(Result, "Error")

End Sub
Public Function FModulo(dVal As Double, ByVal dModVal As Double) As Double

' local variablen
Dim nIntPart As Integer

' calculate floating point modulo value
nIntPart = (dVal / dModVal) - 0.5
dVal = dVal - (nIntPart * dModVal)

' return result
FModulo = dVal

End Function