gisdata.frm

来自「vb+mapx小型地图系统」· FRM 代码 · 共 1,359 行 · 第 1/3 页

      BeginProperty Font 
         Name            =   "宋体"
         Size            =   15
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   9720
      TabIndex        =   5
      Top             =   5520
      Width           =   2535
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件"
      Begin VB.Menu munOpenTable 
         Caption         =   "打开表"
         Shortcut        =   ^O
      End
      Begin VB.Menu munOpengst 
         Caption         =   "打开图集"
      End
      Begin VB.Menu munclosegst 
         Caption         =   "关闭图集"
      End
      Begin VB.Menu munopendatasouce 
         Caption         =   "打开数据源"
         Begin VB.Menu munlineTodata 
            Caption         =   "绑定数据集"
         End
         Begin VB.Menu mundatasearch 
            Caption         =   "数据集信息"
         End
      End
      Begin VB.Menu munloaddata 
         Caption         =   "上载数据"
      End
      Begin VB.Menu munSave 
         Caption         =   "保存"
         Shortcut        =   ^S
      End
      Begin VB.Menu munString 
         Caption         =   "-"
      End
      Begin VB.Menu munQuit 
         Caption         =   "退出"
         Shortcut        =   ^X
      End
   End
   Begin VB.Menu munMapEedit 
      Caption         =   "编辑"
      Begin VB.Menu munlinestyle 
         Caption         =   "线样式"
      End
      Begin VB.Menu munregionstyle 
         Caption         =   "区域样式"
      End
      Begin VB.Menu munsymbostyle 
         Caption         =   "符号样式"
      End
      Begin VB.Menu muntextstyle 
         Caption         =   "文本样式"
      End
      Begin VB.Menu munban2 
         Caption         =   "-"
      End
      Begin VB.Menu munfengen 
         Caption         =   "分割"
      End
      Begin VB.Menu munhebing 
         Caption         =   "合并"
      End
      Begin VB.Menu munBack 
         Caption         =   "撤消"
      End
   End
   Begin VB.Menu muntools 
      Caption         =   "工具"
      Begin VB.Menu mundrawpolyline 
         Caption         =   "画折线"
      End
      Begin VB.Menu mundrawpolyregion 
         Caption         =   "画多边形"
      End
      Begin VB.Menu mundrawzoo 
         Caption         =   "画圆"
      End
   End
   Begin VB.Menu munSql 
      Caption         =   "SQL查询"
      Begin VB.Menu munCserach 
         Caption         =   "精确查询"
      End
      Begin VB.Menu munOsearch 
         Caption         =   "模糊查询"
      End
   End
   Begin VB.Menu munMapSpecial 
      Caption         =   "专题地图"
      Begin VB.Menu munCreatetheme 
         Caption         =   "创建专题图"
      End
      Begin VB.Menu munmodifyTheme 
         Caption         =   "修改专题图"
      End
      Begin VB.Menu munmodifylegend 
         Caption         =   "修改图列"
      End
      Begin VB.Menu munprintTheme 
         Caption         =   "输出专题图"
      End
      Begin VB.Menu munban3 
         Caption         =   "-"
      End
      Begin VB.Menu muncloseTheme 
         Caption         =   "关闭专题图"
      End
   End
   Begin VB.Menu munSpatial 
      Caption         =   "空间分析"
      Begin VB.Menu munbuffered 
         Caption         =   "缓冲区分析"
      End
   End
   Begin VB.Menu munWindow 
      Caption         =   "窗口"
      Begin VB.Menu munlookwindow 
         Caption         =   "浏览属性窗口"
      End
   End
   Begin VB.Menu munprint 
      Caption         =   "打印"
   End
   Begin VB.Menu munHelp 
      Caption         =   "帮助"
      Begin VB.Menu munabout 
         Caption         =   "关于我们.."
      End
      Begin VB.Menu munHelpDo 
         Caption         =   "操作说明"
      End
      Begin VB.Menu munSoftware 
         Caption         =   "版本"
      End
   End
   Begin VB.Menu munRight 
      Caption         =   "rightmouse"
      Visible         =   0   'False
      Begin VB.Menu munlayersconctrol 
         Caption         =   "图层控制"
         Checked         =   -1  'True
      End
      Begin VB.Menu munlooklayers 
         Caption         =   "查看整个图层"
      End
      Begin VB.Menu munban1 
         Caption         =   "-"
      End
      Begin VB.Menu munCopy 
         Caption         =   "复制"
      End
      Begin VB.Menu munCut 
         Caption         =   "剪切"
      End
      Begin VB.Menu munbana 
         Caption         =   "-"
      End
      Begin VB.Menu munCopyTo 
         Caption         =   "粘贴"
      End
   End
End
Attribute VB_Name = "mainform"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim dismap_x As Double

Dim dismap_y As Double
Dim sfile As String
Dim m_Fea As MapXLib.Feature
Dim m_layers As MapXLib.layer

  Dim m_Layer As layer
  Dim m_TempLayer As MapXLib.layer
  Dim Dis As Double
 Dim distancetoolused As Integer
 
  Dim dblFactor As Double
  Dim dtscale As Double
  
 
  
  
  
 
  





Private Sub loadeasy()
loade = Shell(App.Path & "\mapdata\EasyLoader.exe")

End Sub

Public Sub Form_Load()

App.HelpFile = App.Path & "\gisdata.chm"
  
distancetoolused = -1
Screen.MousePointer = 11


Dim str As String
mainform.AutoRedraw = False

Load mainform

munmodifyTheme.Enabled = False
munmodifylegend.Enabled = False
muncloseTheme.Enabled = False

 Map1.MapUnit = miUnitKilometer
  mainform.Top = 200
  mainform.Left = 250
  
 isdatahas = False
 
  
str = App.Path & "\mapdata\mymap.gst"
 Map1.Layers.AddGeoSetLayers str
mundatasearch.Enabled = False

Map1.Bounds = Map1.Layers.Bounds

dblFactor = 0.0003528
dtscale = Map1.Zoom / (Map1.Width * dblFactor)
StatusBar1.Panels(1).Text = "比列尺：    1：" & dtscale
Map1.CreateCustomTool mousepoint, miToolTypePoint, miDefaultCursor

mainform.Show

Screen.MousePointer = 0

End Sub

Private Sub munOpen_Click()
OpenTabFile

End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim move_x As Double

Dim move_y As Double
Map1.ConvertCoord x, y, move_x, move_y, miScreenToMap
StatusBar1.Panels(2).Text = "x=" & move_x
StatusBar1.Panels(3).Text = "y=" & move_y




End Sub

Private Sub Map1_PolyToolUsed(ByVal ToolNum As Integer, ByVal Flags As Long, ByVal Points As Object, ByVal bShift As Boolean, ByVal bCtrl As Boolean, EnableDefault As Boolean)
If ToolNum = 2 Then
    Dim DisSum As Double
Dim Dis As Double
Dim n As Integer
Dim pts As New MapXLib.Points
Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double

Set pts = Points


Select Case Flags
Case miPolyToolBegin
Case miPolyToolInProgress
Case miPolyToolEnd
For i = 1 To pts.Count - 1
X1 = pts.Item(i).x
Y1 = pts.Item(i).y
X2 = pts.Item(i + 1).x
Y2 = pts.Item(i + 1).y
Dis = Map1.Distance(X1, Y1, X2, Y2)
DisSum = DisSum + Dis

Next i
MsgBox "总路程" & Format(str(DisSum), "#,##0.000000") & "千米", 64, "信息提示"



End Select
  End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

If Button = 2 Then
 PopupMenu munRight, 0 Or 0
 
 End If
If Map1.CurrentTool = 1 Then 'read info

Dim map_x As Double
Dim lyr  As MapXLib.layer

Dim map_y As Double
Dim fld As MapXLib.Field

 Dim Fs As MapXLib.Features
Dim ds As MapXLib.Dataset
Dim pt As New MapXLib.Point
Dim strinfo As String

Dim i As Integer, j As Integer

Map1.ConvertCoord x, y, map_x, map_y, MapXLib.ConversionConstants.miScreenToMap
lookinfo.List1.Clear
pt.Set map_x, map_y

     If isdatahas Then
      Set ds = ds1
      Set Fs = Map1.Layers.Item(datahasLayer + 1).SearchAtPoint(pt)
      Else
     ' i = 0
      'j = 0
      ' For Each lyr In Map1.Layers
       ' i = i + 1
       ' If lyr.Editable = True Then
       ' j = i
      '  Exit For
      '  End If
      '  Next
      '  If j > 0 Then
                ' Set Fs = Map1.Layers.Item(j).SearchAtPoint(pt)
      '   Set ds = Map1.DataSets.Add(miDataSetLayer, Map1.Layers.Item(j))
        ' Else
             MsgBox "未绑定数据集", 64, "信息提示"
        ' '
                Exit Sub
        ' End If
         
      
 End If
 If Fs.Count > 0 Then
  For i = 2 To ds.RowValues(Fs.Item(1).FeatureID).Count
  
  
   lookinfo.List1.AddItem ds.Fields(i).Name & ":" & ds.RowValues(Fs.Item(1).FeatureID).Item(i).Value
    Next i
     lookinfo.Show
 
Else
MsgBox "没找到信息", 64, "信息提示"
Exit Sub
End If
End If




  
  



End Sub

Private Sub munabout_Click()
frmAbout.Show modal, Me

End Sub

Private Sub munclosegst_Click()

Map1.GeoSet = ""

End Sub

Private Sub muncloseTheme_Click()
Map1.DataSets("MyDataSet").Themes.Remove c_themename

For Each m_Layer In Map1.Layers
        m_Layer.Refresh
        Next
         mainform.munCreatetheme.Enabled = True
     mainform.munmodifyTheme.Enabled = False
mainform.munmodifylegend.Enabled = False
mainform.muncloseTheme.Enabled = False
        
End Sub

Private Sub munCreatetheme_Click()
createThemes.Show modal, Me

End Sub

Private Sub munCserach_Click()
sqlLook.Show modal, Me

End Sub

Private Sub munHelpDo_Click()
'With CommonDialog1
'.HelpFile = App.Path & "\gisdata.hlp" 'cd1是公用对话框,我故意写成1.hlp
'.'HelpCommand = &H3
''.ShowHelp
'End With
'k = Shell(App.Path & "\gisdata.chm")
'
'Shell "hh.exe gisdata.chm"
CmdHelp_Click

End Sub

Private Sub munlayersconctrol_Click()
Map1.Layers.LayersDlg
relist
End Sub

Private Sub munlinestyle_Click()
tonewlinestyle
End Sub

Private Sub munlineTodata_Click()
linetodata.Show vbModal, Me

End Sub

Private Sub munloaddata_Click()
loadeasy
End Sub

Private Sub munlooklayers_Click()

lookall.Show modal, Me

End Sub

Private Sub munlookwindow_Click()
selectlayer.Show modal, Me
End Sub

Private Sub munmodifylegend_Click()
c_theme.Legend.LegendDlg