gisdata.frm

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

End Sub

Private Sub munmodifyTheme_Click()
c_theme.ThemeDlg

End Sub

Private Sub munOpengst_Click()
  Dim filepath As String
    Dim filename As String
    On Error Resume Next
    With CommonDialog1
    
    .DialogTitle = "打开文件"
   .DefaultExt = "gst"
    .Filter = "MapX GeoSet(*.gst)|*.gst"
    .CancelError = True
    .Action = 1
  If Err.Number = 32755 Then Exit Sub
  If .filename = Map1.GeoSet Then
  MsgBox "请务重复打开同一个地图", , "警告"
  Exit Sub
  End If
Map1.GeoSet = .filename
Map1.Bounds = Map1.Layers.Bounds

End With

End Sub

Private Sub munOpenTable_Click()
Map1.Layers.LayersDlg

End Sub

Private Sub munQuit_Click()
Unload mainform
End Sub

Private Sub munregionstyle_Click()
tonewregionstyle
End Sub

Private Sub munSave_Click()
munSavaGst
End Sub

Private Sub munSoftware_Click()
frmSplash.Show vbModal, Me


End Sub

Private Sub munsymbostyle_Click()
tonewsymbol
End Sub

Private Sub muntextstyle_Click()
tonewTextStyle
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key

Case "key5"
Map1.CreateCustomTool LookInfoTool, miToolTypePoint, miCrossCursor
Map1.CurrentTool = 1
Case "key1"
OpenTabFile
Case "key7"
Map1.CurrentTool = miPanTool
Case "key8"
Map1.CurrentTool = miZoomInTool
Case "key9"
Map1.CurrentTool = miZoomOutTool
Case "key4"
Map1.CurrentTool = miSelectTool
Case "key10"
Map1.Layers.LayersDlg
relist
Case "key12"
tonewTextStyle
Case "key3"
munSavaGst
Case "key13"
 tonewlinestyle
Case "key14"
tonewregionstyle
Case "key6"
getdistance
Case "key15"
Map1.CurrentTool = 3
Dim lyr As MapXLib.layer
For Each lyr In Map1.Layers
   lyr.Selection.ClearSelection
   Next
Case "key11"
Map1.CurrentTool = miPolygonSelectTool




End Select


End Sub

Public Sub OpenTabFile()
  
   
    
    
Map1.Layers.LayersDlg


relist




End Sub
Private Sub Map1_MapViewChanged()
Dim tempFea As MapXLib.Feature
Dim tempPnts As MapXLib.Points
Dim tempStyle As MapXLib.Style
Dim listlayer As layer
List1.Clear

   For Each listlayer In Map1.Layers
   List1.AddItem (listlayer.Name)
   Next
   
Map2.GeoSet = Map1.GeoSet
Map2.Bounds = Map2.Layers.Bounds

Map1.Title.Visible = False
Map2.Title.Visible = False

Set m_TempLayer = Map2.Layers.CreateLayer("T_tempLayer") '给Map2增加临时图层
If m_TempLayer.AllFeatures.Count = 0 Then
'设置矩形边框样式
Set tempStyle = New MapXLib.Style
tempStyle.RegionPattern = miPatternNoFill
tempStyle.RegionBorderColor = 255
tempStyle.RegionBorderWidth = 2
'在临时图层添加大小为Map1的边界的Rectangle对象
Set tempFea = Map2.FeatureFactory.CreateRegion(Map1.Bounds, tempStyle)
Set m_Fea = m_TempLayer.AddFeature(tempFea)
Set tempStyle = Nothing
Else '根据Map1的视野变化改变矩形边框的大小和位置
With m_Fea.Parts.Item(1)
.RemoveAll
.AddXY Map1.Bounds.XMin, Map1.Bounds.YMin
.AddXY Map1.Bounds.XMax, Map1.Bounds.YMin
.AddXY Map1.Bounds.XMax, Map1.Bounds.YMax
.AddXY Map1.Bounds.XMin, Map1.Bounds.YMax
End With
m_Fea.Update
End If
If ToolNum = mizoomin Or ToolNum = mizoomout Then
            dtscale = Map1.Zoom / (Map1.Width * dblFactor)
StatusBar1.Panels(1).Text = "比列尺：    1：" & dtscale
           End If


End Sub




 

   '鹰眼图上鼠标单击用来导航主图，其方法是把鼠标处的坐标设置为主图的中心

Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Dim MapX As Double      '定义x坐标变量

Dim MapY As Double      '定义y坐标变量

'把屏幕坐标转换为地图坐标

Map2.ConvertCoord x, y, MapX, MapY, miScreenToMap

'设置主图的中心x坐标和y坐标

Map1.CenterX = MapX

Map1.CenterY = MapY

End Sub

Private Sub tonewlinestyle()
Dim NewStyle As New MapXLib.Style
  Dim ftrs As Features
  Dim lyrs As layer
  Dim i, j As Integer
  Dim ftr As Feature
  
 i = 0
  Map1.AutoRedraw = False




 For j = 1 To Map1.Layers.Count
 
  If Map1.Layers(j).Editable = True Then
  i = i + 1
  Set ftrs = Map1.Layers(j).Selection.Clone
  Exit For

 End If
 
 Next j
 If i = 0 Then
 MsgBox "请先选择一个图元或设置编辑图层", 64, "信息提示"
 Exit Sub
 
 End If
  If ftrs.Count > o Then
Map1.Layers(j).OverrideStyle = True
NewStyle.PickLine


Set ftr = ftrs.Item(1)
Set ftr.Style = NewStyle
    
                              '更新样式
ftr.Update

  Set NewStyle = Nothing
 
 Map1.GeoSet = Map2.GeoSet
Map1.Bounds = Map1.Layers.Bounds
 
 Map1.Layers(j).Editable = True
 Map1.AutoRedraw = True
  Else
 MsgBox "未找到图元", 64, "信息提示"
 Exit Sub
End If


End Sub

Private Sub tonewregionstyle()
Dim a As Double
Dim x As Double
Dim y As Double

a = Map1.Zoom

Dim NewStyle As New MapXLib.Style
  Dim ftrs As Features
  Dim lyrs As layer
  Dim i, j As Integer
  Dim ftr As Feature
  i = 0
  For j = 1 To Map1.Layers.Count
  If Map1.Layers(j).Editable Then
  i = i + 1
  Set ftrs = Map1.Layers(j).Selection.Clone
  
  Exit For
 End If
 Next j
 If i = 0 Then
 MsgBox "请先选择一个图元或设置编辑图层", 64, "信息提示"
 Exit Sub
  End If
  If ftrs.Count > o Then
 NewStyle.PickRegion
Map1.Layers(j).OverrideStyle = True

Set ftr = ftrs.Item(1)
x = ftr.CenterX
y = ftr.CenterY

Set ftr.Style = ftrs.Item(1).Style



Map1.AutoRedraw = False


Set ftr.Style = NewStyle
    
                              '更新样式
ftr.Update True
 Map1.AutoRedraw = True
 Map1.GeoSet = Map2.GeoSet
 Map1.Zoom = a

 Map1.Bounds = Map1.Layers.Bounds
 Map1.CenterX = x
 Map1.CenterY = y
 Map1.Layers(j).Editable = True
 Map1.AutoRedraw = True
 Else
 MsgBox "未找到图元", 64, "信息提示"
 Exit Sub
End If
Map1.Refresh

End Sub

Private Sub tonewTextStyle()
Dim NewStyle As New MapXLib.Style
  Dim ftrs As Features
  Dim lyrs As layer
  Dim i, j As Integer
  Dim ftr As Feature
  
 i = 0
  Map1.AutoRedraw = False




 For j = 1 To Map1.Layers.Count
 
  If Map1.Layers(j).Editable = True Then
  i = i + 1
  Set ftrs = Map1.Layers(j).Selection.Clone
  Exit For

 End If
 
 Next j
 If i = 0 Then
 MsgBox "请先选择一个图元或设置编辑图层", 64, "信息提示"
 Exit Sub
 
 End If
  If ftrs.Count > o Then
Map1.Layers(j).OverrideStyle = True
NewStyle.PickText


Set ftr = ftrs.Item(1)
Set ftr.Style = NewStyle
    
                              '更新样式
ftr.Update

  Set NewStyle = Nothing
 
 Map1.GeoSet = Map2.GeoSet
Map1.Bounds = Map1.Layers.Bounds
 
 Map1.Layers(j).Editable = True
 Map1.AutoRedraw = True
  Else
 MsgBox "未找到图元", 64, "信息提示"
 Exit Sub
End If
    Map1.Refresh
End Sub

Private Sub tonewsymbol()

Dim NewStyle As New MapXLib.Style
  Dim ftrs As Features
  Dim lyrs As layer
  Dim i, j As Integer
  Dim ftr As Feature
  
 i = 0
  Map1.AutoRedraw = False




 For j = 1 To Map1.Layers.Count
 
  If Map1.Layers(j).Editable = True Then
  i = i + 1
  Set ftrs = Map1.Layers(j).Selection.Clone
  Exit For

 End If
 
 Next j
 If i = 0 Then
 MsgBox "请先选择一个图元或设置编辑图层", 64, "信息提示"
 Exit Sub
 
 End If
  If ftrs.Count > o Then
Map1.Layers(j).OverrideStyle = True
NewStyle.PickSymbol

Set ftr = ftrs.Item(1)
Set ftr.Style = NewStyle
    
                              '更新样式
ftr.Update

  Set NewStyle = Nothing
 
 Map1.GeoSet = Map2.GeoSet
Map1.Bounds = Map1.Layers.Bounds
 
 Map1.Layers(j).Editable = True
 Map1.AutoRedraw = True
  Else
 MsgBox "未找到图元", 64, "信息提示"
 Exit Sub
End If
Map1.Refresh
End Sub

Private Sub getdistance()
Map1.CreateCustomTool distancetool, miToolTypePoly, miCrossCursor
Map1.CurrentTool = distancetool
End Sub

Private Sub relist()
List1.Clear
Dim lyr As MapXLib.layer
For Each lyr In Map1.Layers
  List1.AddItem lyr.Name
  Next
End Sub
Private Sub CmdHelp_Click()
    SendKeys "{F1}" '发送击键到活动窗口
    End Sub
Public Sub munSavaGst()
 Dim filepath As String
    Dim filename As String
    On Error Resume Next
    With CommonDialog1
    
    .DialogTitle = "保存文件"
   .DefaultExt = "gst"
    .Filter = "MapX GeoSet(*.gst)|*.gst"
    .CancelError = True
    .Action = 2
    filepath = .filename
    End With
    If Len(filepath) > 0 Then
    Map1.SaveMapAsGeoset filename, filepath
    Map1.GeoSet = ""
    End If
    If Len(filepath) = 0 Then
    Exit Sub
 
 
     End If
End Sub