frmkzwsj.frm

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

      Begin VB.Menu mnuwxcp 
         Caption         =   "数据文件存盘"
      End
      Begin VB.Menu mnucksjwj 
         Caption         =   "查看数据文件"
      End
      Begin VB.Menu mnujgdy 
         Caption         =   "结果调阅"
      End
      Begin VB.Menu mnuexit 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu mnusht 
      HelpContextID   =  220
      Caption         =   "视图(&V)"
      Begin VB.Menu mnuViewtoolBar 
         Caption         =   "工具栏"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuViewStatusBar 
         Caption         =   "状态栏"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnujsck 
         Caption         =   "监视窗口"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu mnuwxsj 
      HelpContextID   =  230
      Caption         =   "网形设计(&W)"
      Begin VB.Menu mnudbj 
         Caption         =   "网点编辑"
      End
      Begin VB.Menu mnuline 
         Caption         =   "连线"
         Begin VB.Menu mnusblx 
            Caption         =   "鼠标连线"
         End
         Begin VB.Menu mnudhlx 
            Caption         =   "点号连线"
         End
      End
      Begin VB.Menu mnuxs 
         Caption         =   "线删"
         Begin VB.Menu mnusbsx 
            Caption         =   "鼠标删线"
         End
         Begin VB.Menu mnudhsx 
            Caption         =   "点号删线"
         End
      End
   End
   Begin VB.Menu mnugsjd 
      HelpContextID   =  240
      Caption         =   "精度估算(&J)"
      Begin VB.Menu mnujdgs 
         Caption         =   "精度与可靠性估算"
      End
      Begin VB.Menu mnudrawwcty 
         Caption         =   "绘误差椭圆"
      End
      Begin VB.Menu mnutztydx 
         Caption         =   "调整椭圆大小"
      End
   End
   Begin VB.Menu mnucxcg 
      HelpContextID   =  250
      Caption         =   "图上查询成果"
      Begin VB.Menu mnuckkzd 
         Caption         =   "控制点"
      End
      Begin VB.Menu mnuckjx 
         Caption         =   "基线"
      End
   End
   Begin VB.Menu mnust 
      HelpContextID   =  260
      Caption         =   "网图(&S)"
      Begin VB.Menu mnufd 
         Caption         =   "放大"
      End
      Begin VB.Menu mnuwtsx 
         Caption         =   "缩小"
      End
      Begin VB.Menu mnuback 
         Caption         =   "全视"
      End
      Begin VB.Menu mnuyd 
         Caption         =   "移动"
      End
      Begin VB.Menu mnutxsx 
         Caption         =   "刷新"
      End
      Begin VB.Menu mnucls 
         Caption         =   "清屏"
      End
   End
   Begin VB.Menu mnucadjk 
      HelpContextID   =  270
      Caption         =   "CAD接口"
      Begin VB.Menu mnuscr 
         Caption         =   "生成SCR文件"
      End
      Begin VB.Menu mnuckscr 
         Caption         =   "查看SCR文件"
      End
   End
   Begin VB.Menu mnuprint 
      HelpContextID   =  280
      Caption         =   "打印"
   End
   Begin VB.Menu mnuhelp 
      HelpContextID   =  290
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuhelp1 
         Caption         =   "目录"
      End
      Begin VB.Menu mnuabout 
         Caption         =   "关于..."
      End
   End
End
Attribute VB_Name = "frmkzwsj"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, _
           ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Dim my_command As String  '存当前命令
Dim move_mark As Boolean, mark As Boolean    '放大、移动时的条件
Dim mousex0#, cshx1#, cshy1#, cshx2#, cshy2#, mousey0#, mousex1#, mousey1#, mousex2#, mousey2#
Dim my_count%
Public maxx#, maxy#, minx#, miny#  '区域坐标
Dim wxwj As Frmfile
Public wxdk As Boolean            '判断是否从网行文件调入网形
Dim si1#                        'picture1的比例
Dim filenamegs As String         '精度估算所需文件
Dim jdgs1 As GPSjdgs             '定义一个类模块
Public dbj As Boolean       '判断点的编辑,以便判断放大、移动时是否绘网点
Dim hwctyf As Boolean        '判断是否执行了绘误差椭圆的命令
Public dqbl As Double       '记录当前比例

'初始化picture1控件坐标系
Private Sub Screen1_Intilize()
Dim i%, j%, si01#, si02#
Dim minx1#, maxx1#, maxy1#, miny1#
minx1 = minx - 2000
miny1 = miny - 2000
maxx1 = maxx + 2000
maxy1 = maxy + 2000
si01 = (maxx1 - minx1) / Picture1.Width
si02 = (maxy1 - miny1) / Picture1.Height
If si01 > si02 Then
   si1 = si01
Else
   si1 = si02
End If
dqbl = si1 '记录当前比例
StatusBar1.Panels(2).Text = "比例尺:" & " 1:" & Str(Int(dqbl * 56700))
'转换屏幕比例
Picture1.Scale (minx1, miny1 + Picture1.Height * si1)-(minx1 + Picture1.Width * si1, miny1)
'记录当屏幕两角点坐标,移动时用来确定移动范围
cshx1 = minx1
cshy1 = miny1 + Picture1.Height * si1
cshx2 = minx1 + Picture1.Width * si1
cshy2 = miny1
'清除屏幕
Picture1.Picture = LoadPicture()

End Sub

'展点
Public Sub drawwd(object As PictureBox, Bl As Double)
   Dim i As Integer
   Dim color As Long '确定填充颜色
   Dim fillstyle1%, fillcolor1%, forecolor1 As Long
   '记录当前设置以便还原
   fillstyle1 = object.FillStyle
   fillcolor1 = object.FillColor
   forecolor1 = object.ForeColor
   object.DrawMode = 13
   object.FillStyle = 0
   object.FillColor = vbGreen
   object.ForeColor = vbRed
   For i = 1 To yzdgs
      object.Circle (wdxy(i).X, wdxy(i).Y), 40 * Bl, RGB(255, 0, 0)
     color = FloodFill(object.hdc, CLng(wdxy(i).X), CLng(wdxy(i).Y), object.ForeColor)
      CurrentX = wdxy(i).X + 50 * Bl
      CurrentY = wdxy(i).Y
      object.Print i
   Next i
    object.FillStyle = fillstyle1
   object.FillColor = fillcolor1
   object.ForeColor = forecolor1
   object.DrawWidth = 2
   For i = yzdgs + 1 To ii
       object.PSet (wdxy(i).X, wdxy(i).Y), RGB(255, 0, 0)
         CurrentX = wdxy(i).X + 2 * Bl
         CurrentY = wdxy(i).Y
        object.Print i
   Next i
 object.DrawWidth = 1
End Sub
'绘控制网
Public Sub drawkzwx(object As PictureBox)
  Dim i As Integer
  object.DrawStyle = 0
 
  For i = 1 To jj
    object.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
  
End Sub


Private Sub Form_Load()
'*** Code added by HelpWriter ***
    SetApphelp Me.hWnd
'***********************************
   ii = 0: jj = 0
   Set jdgs1 = New GPSjdgs
   mnufd.Enabled = False
   mnuback.Enabled = False
   mnuyd.Enabled = False
   mnuwtsx.Enabled = False
   mnujdgs.Enabled = False
   mnudrawwcty.Enabled = False
   mnutztydx.Enabled = False
   mnuckkzd.Enabled = False
   mnuckjx.Enabled = False
   mnujgdy.Enabled = False
   mnuwxcp.Enabled = False
   mnusblx.Enabled = False
   mnusbsx.Enabled = False
   mnudhlx.Enabled = False
   mnudhsx.Enabled = False
   mnutxsx.Enabled = False
   mnucls.Enabled = False
   mnuprint.Enabled = False
   mnucksjwj.Enabled = False
   mnuscr.Enabled = False
   mnuckscr.Enabled = False
   Toolbar1.Buttons(4).Enabled = False
   Toolbar1.Buttons(6).Enabled = False
   Toolbar1.Buttons(10).Enabled = False
   Toolbar1.Buttons(9).Enabled = False
   Toolbar1.Buttons(8).Enabled = False
   Toolbar1.Buttons(17).Enabled = False
   Toolbar1.Buttons(12).Enabled = False
   Toolbar1.Buttons(13).Enabled = False
   Toolbar1.Buttons(15).Enabled = False
   Toolbar1.Buttons(16).Enabled = False
   Toolbar1.Buttons(14).Enabled = False
   Toolbar1.Buttons(20).Enabled = False
   Toolbar1.Buttons(19).Enabled = False
   jsck.Show 0, Me
End Sub

Private Sub Form_Resize()
  Picture1.Move 0, 0, ScaleWidth, ScaleHeight - 390
  Text1.Move 2055, ScaleHeight - 300
  Text2.Move 3915, ScaleHeight - 300
  jsck.Move frmkzwsj.ScaleWidth - 3375, 1500
End Sub


Private Sub mnuabout_Click()
  frmabout.Show 1, Me
End Sub
'还原图形
Private Sub mnuback_Click()
Picture1.Picture = LoadPicture()
'Picture1.MousePointer = 1
If wxdk Then
    Call Screen1_Intilize
    Call drawkzwx(Picture1)
    Call drawwd(Picture1, si1)
End If
If hwctyf Then Call jdgs1.hwcty(Picture1, dqbl, tydx)
End Sub

'估算结束后在图上查看基线精度
Private Sub mnuckjx_Click()
  Picture1.MousePointer = 14
  my_command = "cjxcg"
End Sub

'估算结束后在图上查点精度
Private Sub mnuckkzd_Click()
 Picture1.MousePointer = 14
 my_command = "ckzdxx"
End Sub

'查看scr文件
Private Sub mnuckscr_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 & ".scr")
 End If
End Sub

Private Sub mnucksjwj_Click()
Cgdy (filenamegs)
End Sub

'清除屏幕
Private Sub mnucls_Click()
  Picture1.Cls
  jsck.Pic.Cls
  Picture1.MousePointer = 1
  my_command = ""
  ii = 0
  jj = 0
' If wxdk Then wxwj.file13 = ""
End Sub
'编辑控制点
Private Sub mnudbj_Click()
  frmdbj.Show 1, Me
End Sub
'通过点号连线
Private Sub mnudhlx_Click()
  Frmdh.Show 1, Me
  If Frmdh.dydh <> 0 And Frmdh.dedh <> 0 Then
      jj = jj + 1
      ReDim Preserve wxsj(1 To jj)
      wxsj(jj).bh = jj
      wxsj(jj).dh1 = Frmdh.dydh
      wxsj(jj).dh2 = Frmdh.dedh
      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
End Sub
'点号删线
Private Sub mnudhsx_Click()
Dim i%, jxh%
  Frmdh.Show 1, Me
  If Frmdh.dydh <> 0 And Frmdh.dedh <> 0 Then
      jxh = zjxh2(Frmdh.dydh, Frmdh.dedh, wxsj(), jj)
       If jxh <> 0 Then
           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