frmkzwsj.frm

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

      End If
      Picture1.DrawMode = 10
      jsck.Pic.DrawMode = 10
      Picture1.Line (wdxy(Frmdh.dydh).X, wdxy(Frmdh.dydh).Y)-(wdxy(Frmdh.dedh).X, wdxy(Frmdh.dedh).Y), RGB(0, 0, 255)
      jsck.Pic.Line (wdxy(Frmdh.dydh).X, wdxy(Frmdh.dydh).Y)-(wdxy(Frmdh.dedh).X, wdxy(Frmdh.dedh).Y), RGB(0, 0, 255)
 End If
    Picture1.DrawMode = 13
    jsck.Pic.DrawMode = 13
End Sub
'绘误差椭圆
Private Sub mnudrawwcty_Click()
 tydx = 15
 hwctyf = True
 mnutztydx.Enabled = True
 If wxdk Then
    Call jdgs1.hwcty(Picture1, dqbl, tydx)
 Else
    MsgBox "请先绘网图", vbOKOnly, "提示"
 End If
    
End Sub

Private Sub mnuExit_Click()
  End
End Sub

Private Sub mnufd_Click()
  Picture1.MousePointer = 99
  Picture1.MouseIcon = LoadPicture("c:\rsrc\zoomin1.ico")
  my_command = "fd"
End Sub
'精度估算
Private Sub mnuJDGS_Click()
  Presbar.Visible = True
  Call jdgs1.Main(filenamegs)
  mnudrawwcty.Enabled = True
  mnuckkzd.Enabled = True
  mnuckjx.Enabled = True
  mnuscr.Enabled = True
  Toolbar1.Buttons(10).Enabled = True
  Toolbar1.Buttons(20).Enabled = True
  Toolbar1.Buttons(19).Enabled = True
  mnujgdy.Enabled = True
End Sub

'成果调阅
Private Sub mnujgdy_Click()
Dim i%
Dim filename2
filename2 = ""
If filenamegs <> "" Then
For i = 1 To Len(filenamegs)
    If Mid(filenamegs, i, 1) = "." Then
      Exit For
    Else
      filename2 = filename2 + Mid(filenamegs, i, 1)
    End If
 Next i
 Call Cgdy(filename2 & ".out")
 End If
End Sub


'建立数据文件
Private Sub mnujlsjwj_Click()
  Dim i%
  
   With ComDialog1
    ' 设置“CancelError”为 True
    .CancelError = True
    On Error GoTo ErrHandler
' 设置标志
     .Flags = cdlOFNHideReadOnly
     .Filter = "In (*.in)|*.in|Out (*.out)|*.out|Dat (*.dat) |*.dat|所有文件 (*.*)|*.*"
     .ShowSave
' 显示选定文件的名字
newfilename = .filename
End With
If newfilename <> "" Then
  mnujdgs.Enabled = True
  mnucksjwj.Enabled = True
  wxdk = True
  mnuwxcp.Enabled = True
  mnusblx.Enabled = True
  mnusbsx.Enabled = True
  mnudhlx.Enabled = True
  mnudhsx.Enabled = True
  mnutxsx.Enabled = True
  mnucls.Enabled = True
  mnuprint.Enabled = True
  Toolbar1.Buttons(4).Enabled = True
  Toolbar1.Buttons(6).Enabled = True
  Toolbar1.Buttons(8).Enabled = True
  Toolbar1.Buttons(9).Enabled = True
  Toolbar1.Buttons(14).Enabled = True
  Toolbar1.Buttons(12).Enabled = True
  Toolbar1.Buttons(13).Enabled = True
  Toolbar1.Buttons(15).Enabled = True
  Toolbar1.Buttons(16).Enabled = True
  Toolbar1.Buttons(17).Enabled = True
  filenamegs = newfilename
  Open newfilename For Output As #1
  Frmjlsjwj.Show 1, Me
 
End If
 Exit Sub

ErrHandler:
' 用户按了“取消”按钮
Exit Sub
End Sub


'监视窗口的状态
Private Sub mnujsck_Click()
 If mnujsck.Checked Then
        Unload jsck
        mnujsck.Checked = False
 Else
        jsck.Show 0, Me
        mnujsck.Checked = True
 End If
 
End Sub

'打印图形
Private Sub mnuprint_Click()
Dim i%  ', swidth%, sheight%
ComDialog1.ShowPrinter
Printer.Scale (CDbl(minx), CDbl(miny) + Picture1.Height * si1)-(CDbl(minx) + Picture1.Width * si1, CDbl(miny))
    Printer.DrawWidth = 2
   For i = 1 To ii
     Printer.PSet (wdxy(i).X, wdxy(i).Y), RGB(255, 0, 0)
     CurrentX = wdxy(i).X + 2 * si1
     CurrentY = wdxy(i).Y
     Printer.Print i
   Next i
 Printer.DrawWidth = 1
  For i = 1 To jj
    Printer.Line (wdxy(wxsj(i).dh1).X, wdxy(wxsj(i).dh1).Y)-(wdxy(wxsj(i).dh2).X, wdxy(wxsj(i).dh2).Y), RGB(0, 0, 255)
  Next i
 Printer.EndDoc
End Sub

Private Sub mnusblx_Click()
   Picture1.MousePointer = 99
   Picture1.MouseIcon = LoadPicture("c:\rsrc\jxk2.ico")
   my_command = "sblx"
   my_count = 1
End Sub

Private Sub mnusbsx_Click()
  Picture1.MousePointer = 99
  Picture1.MouseIcon = LoadPicture("c:\rsrc\jxk2.ico")
  my_command = "sbsx"
End Sub

'删点
Private Sub mnusd_Click()
   my_command = "wdsc"
End Sub

Private Sub mnuscr_Click()
  Dim tyf As String
  mnuckscr.Enabled = True
  tyf = MsgBox("是否绘制误差椭圆？", vbYesNo, "提示")
  If tyf = vbYes Then
    wtbl = InputBox("请输入网图绘制比例尺分母", "输入")
    tybl = InputBox("请输入椭圆显示比例", "输入")
    jdgs1.Jdfbt (1)
 Else
   wtbl = InputBox("请输入网图绘制比例尺分母", "输入")
   jdgs1.Jdfbt (0)
 End If
 MsgBox "文件已生成！", vbOKOnly, "提示"
 
End Sub

'找区域初始化屏幕展点
Public Sub zkzd()
Dim i%
If ii > 1 Then
   minx = wdxy(1).X: miny = wdxy(1).Y
  maxx = wdxy(1).X: maxy = wdxy(1).Y
  For i = 1 To ii
    If wdxy(i).X < minx Then minx = wdxy(i).X
    If wdxy(i).Y < miny Then miny = wdxy(i).Y
    If wdxy(i).X > maxx Then maxx = wdxy(i).X
    If wdxy(i).Y > maxy Then maxy = wdxy(i).Y
 Next i
   Call Screen1_Intilize
   Call drawwd(Picture1, si1)
   mnufd.Enabled = True
   mnuback.Enabled = True
   mnuyd.Enabled = True
   mnuwtsx.Enabled = True
  End If
End Sub

'刷新
Private Sub mnutxsx_Click()
Picture1.Picture = LoadPicture()
If wxdk Then
    Call drawkzwx(Picture1)
    Call drawwd(Picture1, dqbl)
End If
If hwctyf Then Call jdgs1.hwcty(Picture1, dqbl, tydx)

End Sub

Private Sub mnutztydx_Click()
  tydx = CLng(InputBox("输入椭圆调整比例：", "输入", 15))
  If tydx > 0 Then
   If wxdk Then
    Call drawkzwx(Picture1)
    Call drawwd(Picture1, dqbl)
   End If
   Call jdgs1.hwcty(Picture1, dqbl, tydx)
  End If
End Sub

Private Sub mnuwtsx_Click()
  Picture1.MousePointer = 99
  Picture1.MouseIcon = LoadPicture("c:\rsrc\zoomout1.ico")
  my_command = "wtsx"
End Sub

'网形存盘
Private Sub mnuwxcp_Click()
Dim filename1 As String
Dim filenum As Integer
Dim i As Integer
If wxdk Then
   filenum = FreeFile
   Open wxwj.file13 For Output As #filenum
Else
  With ComDialog1
    ' 设置“CancelError”为 True
    .CancelError = True
    On Error GoTo ErrHandler
' 设置标志
     .Flags = cdlOFNHideReadOnly
     .Filter = "Dat (*.dat)|*.dat|所有文件 (*.*)|*.*"
     .ShowSave
' 显示选定文件的名字
filename1 = .filename
End With
filenum = FreeFile
Open filename1 For Output As #filenum
End If
Write #filenum, Kzwmc
Write #filenum, yzdgs, ii, jj
Write #filenum, bca, bcb, bcc, bcd
For i = 1 To ii
  Write #filenum, i, wdxy(i).Name, wdxy(i).Y, wdxy(i).X
Next i
For i = 1 To jj
  Write #filenum, wxsj(i).dh1, wxsj(i).dh2
Next i
Close #filenum
Exit Sub

ErrHandler:
' 用户按了“取消”按钮
Exit Sub
End Sub


'打开数据文件
Private Sub mnuwxwj_Click()
  Dim filenum
  Dim count As Integer, count1 As Integer, i%
  Set wxwj = New Frmfile
  With wxwj
     .Label1 = "键入数据文件名称、路径："
     .ComDialog.Filter = "Txt(*.txt)|*.txt|Dat (*.dat) |*.dat|In (*.in)|*.in|Out (*.out)|*.out|所有文件 (*.*)|*.*"
  End With
  wxwj.Show 1, Me
  filenum = FreeFile
  If wxwj.file13 <> "" Then
  On Error GoTo cwcl
    filenamegs = wxwj.file13
    mnujdgs.Enabled = True
    mnucksjwj.Enabled = True
   wxdk = True
   mnuwxcp.Enabled = True
   mnusblx.Enabled = True
   mnusbsx.Enabled = True
   mnudhlx.Enabled = True
   mnudhsx.Enabled = True
   mnutxsx.Enabled = True
   mnucls.Enabled = True
   mnuprint.Enabled = True
   Toolbar1.Buttons(4).Enabled = True
   Toolbar1.Buttons(6).Enabled = True
   Toolbar1.Buttons(8).Enabled = True
   Toolbar1.Buttons(9).Enabled = True
   Toolbar1.Buttons(14).Enabled = True
   Toolbar1.Buttons(12).Enabled = True
   Toolbar1.Buttons(13).Enabled = True
   Toolbar1.Buttons(15).Enabled = True
   Toolbar1.Buttons(16).Enabled = True
   Toolbar1.Buttons(17).Enabled = True
  Open wxwj.file13 For Input As #filenum
  Input #filenum, Kzwmc
  Input #filenum, yzdgs, count, count1
  Input #filenum, bca, bcb, bcc, bcd
  ReDim wdxy(1 To count)
  ii = count
  For i = 1 To count
    Input #filenum, wdxy(i).dh, wdxy(i).Name, wdxy(i).Y, wdxy(i).X
  Next i
    Do Until EOF(filenum)
      jj = jj + 1
      ReDim Preserve wxsj(1 To jj)
      Input #filenum, wxsj(jj).dh1, wxsj(jj).dh2
    Loop
   Close #filenum
   frmkzwsj.Caption = "GPS控制网设计及网图显示" & " - " & Kzwmc
   Call zkzd       '初始化屏幕绘控制点
   Call drawkzwx(Picture1)
   Call jsck.jsck_draw
 End If
 Exit Sub
cwcl:

  MsgBox "文件选择错误!请重新输入", vbOKOnly, "提示"
  Close #filenum
  Exit Sub
  
End Sub

Private Sub mnuyd_Click()
 Picture1.MousePointer = 99
 Picture1.MouseIcon = LoadPicture("c:\rsrc\hand.ico")
 my_command = "pan"
 my_count = 1
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i%
    Dim sxdh As Integer
    Static jxd1%
    Dim jxh%
    Dim dqminx#, dqminy#, dqmaxx#, dqmaxy#
    Dim sxbl#, sxbl1#, sxbl2#

    If my_command = "fd" Then
         If Button = 1 Then
            mousex1 = X
            mousey1 = Y
            mark = True
            move_mark = True
         End If
      End If
  ''''''''''*********** 扫视函数 Pan *************
  If my_command = "pan" Then
    If Button = 1 And my_count = 1 Then
       mousex1 = X
       mousey1 = Y
       move_mark = True
       mark = True
       my_count = 2