frmkzwsj.frm

gps控制网设计 gps控制网设计 gps控制网设计

    ElseIf Button = 1 And my_count = 2 Then
       mousex2 = X
       mousey2 = Y
       my_count = 1
      ' my_command = ""
       move_mark = False
       DrawStyle = 0
       DrawMode = 13
       Picture1.Scale (cshx1 - (mousex2 - mousex1), cshy1 - (mousey2 - mousey1))-(cshx2 - (mousex2 - mousex1), cshy2 - (mousey2 - mousey1))
       cshx1 = cshx1 - (mousex2 - mousex1)
       cshy1 = cshy1 - (mousey2 - mousey1)
       cshx2 = cshx2 - (mousex2 - mousex1)
       cshy2 = cshy2 - (mousey2 - mousey1)
       Picture1.Picture = LoadPicture()
     If wxdk Then
        Call drawwd(Picture1, dqbl)
        Call drawkzwx(Picture1)
       
     End If
     If hwctyf Then Call jdgs1.hwcty(Picture1, dqbl, tydx)
     End If
  End If
  '******************鼠标连线**************
  If my_command = "sblx" Then
      
      If Button = 1 And my_count = 1 Then
      
      sxdh = zwdh(CDbl(X), CDbl(Y), wdxy, ii)
      If sxdh <> 0 Then
       jj = jj + 1
       ReDim Preserve wxsj(1 To jj)
       wxsj(jj).bh = jj
       wxsj(jj).dh1 = sxdh            '记录基线第一点号存网形
       mousex1 = wdxy(sxdh).X
       mousey1 = wdxy(sxdh).Y
       my_count = 2
      Else
         MsgBox "没有选中的点，重新选择", , "提示"
         my_count = 1
      End If
    ElseIf Button = 1 And my_count = 2 Then
    
      sxdh = zwdh(CDbl(X), CDbl(Y), wdxy, ii)
     If sxdh <> 0 Then
       wxsj(jj).dh2 = sxdh            ' 第二点号
       mousex2 = wdxy(sxdh).X
       mousey2 = wdxy(sxdh).Y
       my_count = 1
       Picture1.Line (mousex1, mousey1)-(mousex2, mousey2), RGB(0, 0, 255)
       jsck.Pic.Line (mousex1, mousey1)-(mousex2, mousey2), RGB(0, 0, 255)
       If wxsj(jj).dh1 = wxsj(jj).dh2 Then jj = jj - 1
    Else
         MsgBox "没有选中的点，重新选择", , "提示"
         my_count = 2
     End If
     End If
  End If
  '****************鼠标删线*********************
   If my_command = "sbsx" And Button = 1 Then
     If wxdk Then jxh = zjxh(X, Y, wdxy(), wxsj(), jj)
     If jxh <> 0 Then
       Picture1.DrawMode = 10
       jsck.Pic.DrawMode = 10
       Picture1.Line (wdxy(wxsj(jxh).dh1).X, wdxy(wxsj(jxh).dh1).Y)-(wdxy(wxsj(jxh).dh2).X, wdxy(wxsj(jxh).dh2).Y), RGB(0, 0, 255)
       jsck.Pic.Line (wdxy(wxsj(jxh).dh1).X, wdxy(wxsj(jxh).dh1).Y)-(wdxy(wxsj(jxh).dh2).X, wdxy(wxsj(jxh).dh2).Y), RGB(0, 0, 255)

           If jxh <> jj Then
              For i = jxh To jj - 1
               wxsj(i).bh = i
               wxsj(i).dh1 = wxsj(i + 1).dh1
               wxsj(i).dh2 = wxsj(i + 1).dh2
              Next i
              jj = jj - 1
            Else
               jj = jj - 1
           End If
       If jj > 0 Then ReDim Preserve wxsj(1 To jj)
     End If
     Picture1.DrawMode = 13
     jsck.Pic.DrawMode = 13
  End If
  ' ***************删点*****************
  If my_command = "wdsc" And Button = 1 Then
    sxdh = zwdh(CDbl(X), CDbl(Y), wdxy, ii)
    If sxdh <> 0 Then
     If sxdh <> ii Then
       For i = sxdh To ii - 1
         wdxy(i).X = wdxy(i + 1).X
         wdxy(i).Y = wdxy(i + 1).Y
       Next i
       ii = ii - 1
     Else
       ii = ii - 1
     End If
     Picture1.Cls
    Call drawwd(Picture1, dqbl)
   ' Call drawwd(Picture2, si2)
   Else
     MsgBox "不确定的选择，请重选！", , "提示信息"
   End If
  End If
  
  '****************************选点****************
  If my_command = "tsxd" And Button = 1 Then
     ii = ii + 1
    ReDim Preserve wdxy(1 To ii)
     wdxy(ii).X = CDbl(X)
     wdxy(ii).Y = CDbl(Y)
     
    Picture1.Circle (wdxy(ii).X, wdxy(ii).Y), 10 * dqbl, RGB(255, 0, 0)
    jsck.Pic.Circle (wdxy(ii).X, wdxy(ii).Y), 10 * jsck.si2, RGB(255, 0, 0)
    
    CurrentX = wdxy(ii).X + 2
    CurrentY = wdxy(ii).Y
    Picture1.ForeColor = RGB(255, 0, 0)
    Picture1.Print ii
   Picture1.ForeColor = RGB(0, 0, 0)
   End If
  
'*******************网图缩小*****************
  If my_command = "wtsx" And Button = 1 Then
        dqminx = cshx1 - 2000
        dqmaxy = cshy1 + 2000
        dqmaxx = cshx2 + 2000
        dqminy = cshy2 - 2000
        sxbl1 = (dqmaxx - dqminx) / Picture1.Width
      sxbl2 = (dqmaxy - dqminy) / Picture1.Height
      If sxbl1 > sxbl2 Then
        sxbl = sxbl1
      Else
         sxbl = sxbl2
      End If
     dqbl = sxbl    '记录当前比例
     StatusBar1.Panels(2).Text = "比例尺:" & " 1:" & Str(Int(dqbl * 56700))

       '转换屏幕比例
      Picture1.Scale (dqminx, dqminy + Picture1.Height * dqbl)-(dqminx + Picture1.Width * dqbl, dqminy)
        cshx1 = dqminx
        cshy1 = dqminy + Picture1.Height * dqbl
        cshx2 = dqminx + Picture1.Width * dqbl
        cshy2 = dqminy
        Picture1.Picture = LoadPicture()
          Call drawwd(Picture1, dqbl)
          Call drawkzwx(Picture1)
          Call jdgs1.hwcty(Picture1, dqbl, tydx)
 End If
'*****************查点误差**************
    If my_command = "ckzdxx" And Button = 1 Then
  
        sxdh = zwdh(CDbl(X), CDbl(Y), wdxy, ii)
       If sxdh <> 0 Then Call jdgs1.xdwwc(sxdh)

    End If
  
 '***************查基线误差*****************
     If my_command = "cjxcg" And Button = 1 Then
     
       If wxdk Then jxh = zjxh(X, Y, wdxy(), wxsj(), jj)
       If jxh <> 0 Then Call jdgs1.xjxjd(jxh)
  
    End If
'***********************************************
 If Button = 2 Then
   PopupMenu mnust
 End If
    
End Sub

Private Sub picture1_mousemove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  '********************* 放大函数的橡皮筋技术 ******************
    Dim Dlt#
   If move_mark And my_command = "fd" Then
     Picture1.DrawStyle = 1
     Picture1.DrawMode = 10
     If mark Then
        mousex0 = X
        mousey0 = Y
        Picture1.Line (mousex1, mousey1)-(mousex0, mousey0), , B
        mark = False
     Else
        Picture1.Line (mousex1, mousey1)-(mousex0, mousey0), , B
        mousex0 = X
        mousey0 = Y
        Picture1.Line (mousex1, mousey1)-(mousex0, mousey0), , B
     End If
   End If
   Picture1.DrawStyle = 0
   Picture1.DrawMode = 13
   Text1.Text = Format(Y, "0.000")
   Text2.Text = Format(X, "0.000")
   Picture1.ToolTipText = ""
   Dlt = zwdh(CDbl(X), CDbl(Y), wdxy, ii)
   If Dlt <> 0 Then
    If Dlt <= yzdgs Then
    Picture1.ToolTipText = "点号: " & Format(Dlt, "00") & Space(4) & "点名：" & wdxy(Dlt).Name & Space(4) & "X: " & _
     Format(wdxy(Dlt).Y, "#.000") & Space(4) & "Y: " & Format(wdxy(Dlt).X, "#.000") & "    起算点"
   Else
      Picture1.ToolTipText = "点号: " & Format(Dlt, "00") & Space(4) & "点名：" & wdxy(Dlt).Name & Space(4) & "X: " & _
     Format(wdxy(Dlt).Y, "#.000") & Space(4) & "Y: " & Format(wdxy(Dlt).X, "#.000")
   End If
   End If
   '****************** 扫视函数 Pan ******************
   If my_command = "pan" And move_mark = True Then
      Picture1.DrawStyle = 1
      Picture1.DrawMode = 6
      If mark = True Then
        mousex0 = X
        mousey0 = Y
        Picture1.Line (mousex1, mousey1)-(mousex0, mousey0)
        mark = False
      Else
         Picture1.Line (mousex1, mousey1)-(mousex0, mousey0)
         mousex0 = X
         mousey0 = Y
         Picture1.Line (mousex1, mousey1)-(mousex0, mousey0)
      End If
    End If
End Sub
Private Sub picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   '****************** 放大函数 start ****************
   Dim BlyzX#, BlyzY#, blyz0#
   If Button = 1 And my_command = "fd" Then
      Picture1.DrawMode = 13
      Picture1.DrawStyle = 0
      Picture1.Line (mousex1, mousey1)-(X, Y), QBColor(13), B
      mousex2 = X
      mousey2 = Y
      move_mark = False
      BlyzX = Abs(mousex1 - X) / Picture1.Width
      BlyzY = Abs(mousey1 - Y) / Picture1.Height
      blyz0 = BlyzX
      If BlyzY > BlyzX Then
         blyz0 = BlyzY
      End If
      dqbl = blyz0
      StatusBar1.Panels(2).Text = "比例尺:" & " 1:" & Str(Int(dqbl * 56700))
      If mousex1 < X And mousey1 < Y Then
            Picture1.Scale (mousex1, mousey1 + blyz0 * Picture1.Height)-(mousex1 + blyz0 * Picture1.Width, mousey1)
            cshx1 = mousex1
            cshy1 = mousey1 + blyz0 * Picture1.Height
            cshx2 = mousex1 + blyz0 * Picture1.Width
            cshy2 = mousey1
        End If
      
      If mousex1 < X And mousey1 > Y Then
            Picture1.Scale (mousex1, Y + blyz0 * Picture1.Height)-(mousex1 + blyz0 * Picture1.Width, Y)
            cshx1 = mousex1
            cshy1 = Y + blyz0 * Picture1.Height
            cshx2 = mousex1 + blyz0 * Picture1.Width
            cshy2 = Y
      End If
      If X < mousex1 Then
           MsgBox "选点的顺序错误，请重选！"
           my_command = ""
      End If
      Picture1.Cls
     If wxdk Then
        Call drawwd(Picture1, dqbl)
        Call drawkzwx(Picture1)
     End If
     If hwctyf Then Call jdgs1.hwcty(Picture1, dqbl, tydx)
    End If
    ''******************** 放大函数 end ******************
    
 End Sub


Public Sub txyd(XX As Single, YY As Single)
 If wxdk Then
  If dqbl <> 0 Then
   Picture1.Scale (XX - 2000 * dqbl, YY + 2000 * dqbl)-(XX + 2000 * dqbl, YY - 2000 * dqbl)
   Picture1.Picture = LoadPicture()
     If wxdk Then
       Call drawwd(Picture1, dqbl)
       Call drawkzwx(Picture1)
     End If
   If hwctyf Then Call jdgs1.hwcty(Picture1, dqbl, tydx)
  End If
  End If

End Sub


Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)

    Select Case Button.Key
       Case "new"
           mnujlsjwj_Click
        Case "open"
           mnuwxwj_Click
        Case "save"
            mnuwxcp_Click
        Case "line"
           mnusblx_Click
        Case "delline"
            mnusbsx_Click
        Case "fd"
            mnufd_Click
        Case "yd"
            mnuyd_Click
        Case "qs"
            mnuback_Click
        Case "zjsjx"
            mnujlsjwj_Click
        Case "cdjd"
           mnuckkzd_Click
        Case "wcty"
           mnudrawwcty_Click
        Case "cxjd"
           mnuckjx_Click
        Case "sx"
            mnuwtsx_Click
        Case "shuxin"
           mnutxsx_Click
        Case "xjsck"
           mnujsck_Click
        Case "help"
           mnuabout_Click
        Case "zkcz"
          Picture1.MousePointer = 1
           my_command = ""
    End Select


End Sub



Private Sub mnuViewStatusBar_Click()
    If mnuViewStatusBar.Checked Then
        StatusBar1.Visible = False
        Text1.Visible = False
        Text2.Visible = False
        mnuViewStatusBar.Checked = False
    Else
        StatusBar1.Visible = True
         Text1.Visible = True
        Text2.Visible = True
        mnuViewStatusBar.Checked = True
    End If
End Sub


Private Sub mnuViewToolbar_Click()
    If mnuViewtoolBar.Checked Then
        Toolbar1.Visible = False
        mnuViewtoolBar.Checked = False
    Else
        Toolbar1.Visible = True
        mnuViewtoolBar.Checked = True
    End If
End Sub

Sub Form_UnLoad (Cancel as Integer)
'*** Code added by HelpWriter ***
'*** Subroutine added by HelpWriter ***
    QuitHelp
'***********************************
End Sub