form1.frm

mo2.4+vb开发的一个小的地理信息系统

      Begin VB.Menu mun_help_aboat 
         Caption         =   "关于"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' 定义窗体变量
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
' 定义标志变量
Dim icolor As Integer
Dim flag As Integer
' 定义几何对象 点，线，多边行
Dim mypoint As MapObjects2.Point
Dim myline As MapObjects2.Line
Dim mypolygen As MapObjects2.Polygon
'定义一个记录集recshap，和一个对象 shp
Dim recshap As MapObjects2.Recordset
Dim shp As Object
' 定义一个四边形 rcg
Dim rcg As MapObjects2.Rectangle
'定义一个地理数据集gds，和一个数据库连接dbconnction
Dim gds As New MapObjects2.GeoDataset
Dim dbconnction As New MapObjects2.DataConnection
 
'Public Map3 As Map   可以定义一个全局的map

Private Sub Form_Load()
 '加载动态图层
 begingtrackLar
 '设置状态条
 StsBar1.Panels.Item(1).Style = sbrDate
 StsBar1.Panels.Item(1).Width = 1200
 StsBar1.Panels.Item(3).Width = 800
 StsBar1.Panels(3).Style = sbrNum
 
End Sub

Private Sub legend1_AfterSetLayerVisible(Index As Integer, isVisible As Boolean)
Map1.Refresh

End Sub

Private Sub legend1_LayerDblClick(Index As Integer) '图例 双击将图层的的字段名加到列表框list1中
Dim ofiled As MapObjects2.Field
list1.Clear
For Each ofiled In Map1.Layers(Index).Records.Fields
list1.AddItem ofiled.Name
Next

'begin with id num
list1.ListIndex = 0

End Sub

Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hDC As stdole.OLE_HANDLE)
  Dim sym As New MapObjects2.Symbol
  sym.SymbolType = moFillSymbol
  sym.Style = moSolidFill
  sym.Color = moYellow
  On Error Resume Next
  
  Select Case flag
  Case 4  '查询属性乐
    If Not recshap Is Nothing Then
    Map1.DrawShape recshap, sym  '将选择的要素 绘制以便了
    End If
    Map1.Refresh      '  map1刷新 呢
    Set recshap = Nothing  '将指正推出内存了，   收 工
  
  Case 5  '点缓冲了
    If Not recshap Is Nothing Then
           Set shp = recshap("Shape").Value
         
           Set mypolygen = shp.Buffer(0.8, Map1.FullExtent) '缓冲半径 0.8
           
           If Not mypolygen Is Nothing Then
            Map1.DrawShape mypolygen, sym '绘制着个多变形mypolygen 用符号sym 来 描绘他 了
            Map1.Refresh
           End If
          Set recs = recshap
          '查询属性啊
          Load frmquery
          frmquery.Show
           
           Set recshap = Nothing
         End If
Case 6   '线缓冲
        Set mypolygen = myline.Buffer(1.6, Map1.FullExtent) '缓冲半径 1.6
       If Not mypolygen Is Nothing Then
        Map1.DrawShape mypolygen, sym '绘制着个多变形mypolygen 用符号sym 来 描绘他 了
       End If
      
Case 7 '面缓冲
 
    Set mypolygen = rcg.Buffer(1.5, Map1.FullExtent)  '缓冲半径 1.5
    If Not mypolygen Is Nothing Then
    Map1.DrawShape mypolygen, sym  '绘制着个多变形mypolygen 用符号sym 来 描绘他 了
    End If
    
       
 End Select

 
  
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim loc As New MapObjects2.Point
Dim mapwidth As Double
Dim mapheight As Double


On Error Resume Next

Select Case flag
Case 1  '放大
 Set rcg = Map1.TrackRectangle
 Map1.Extent = rcg
 Map1.Refresh
 
Case 2  '缩小
Set loc = Map1.ToMapPoint(x, y)
Set rcg = Map1.Extent
rcg.ScaleRectangle 1.5
Set Map1.Extent = rcg

Case 3  '移动
Map1.Pan

Case 4  '判断图层的类型，并根据类型查找属性
 Set lar = Map1.Layers(0)
 If lar.shapeType = moShapeTypePoint Then
 Set rcg = Map1.TrackRectangle
 Set recs = lar.SearchShape(rcg, moContaining, "")
 ElseIf lar.shapeType = moShapeTypeLine Then
 Set myline = Map1.TrackLine
 Set recs = lar.SearchShape(myline, moLineCross, "")
 ElseIf lar.shapeType = moShapeTypePolygon Then
 Set selpnt = Map1.ToMapPoint(x, y)
 Set recs = lar.SearchShape(selpnt, moPointInPolygon, "")
 Map1.FlashShape selpnt, 5
 End If

 Set recshap = recs
 '将所有在记录集种的要素 晃几下———— 3 下 了
 Do While Not recs.EOF
 Set shp = recs.Fields("Shape").Value
 Map1.FlashShape shp, 3
 recs.MoveNext
 Loop
 '查找属性了
 Map1.Refresh
 Load frmquery
 frmquery.Show
 
Case 5   '点缓冲 方法SearchByDistance
        Set recshap = Nothing
        Set mypoint = Map1.ToMapPoint(x, y)
        Set recshap = Map1.Layers(0).SearchByDistance(mypoint, Map1.ToMapDistance(60), "")
        Map1.Refresh

Case 6  '线缓冲
  
         Set myline = Map1.TrackLine
'        Map1.TrackingLayer.Refresh True
         Map1.Refresh
Case 7 '面缓冲
    Set rcg = Map1.TrackRectangle
    Map1.Refresh
    
Case 8  '添加事件
  AddEvent x, y
Case 9 '选择事件
  slectevent
  

End Select

End Sub


Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '设置猫眼
'在鼠标按下时，将追中的矩形给rcg
Set rcg = Map2.TrackRectangle
'将rcg扩冲到 map1的范围
Map1.Extent = rcg
Map1.Refresh
End Sub

Private Sub mnu_file_open_Click()
 
Dim filename As String '定义文件名字
Dim filepath As String '定义文件路径
 
On Error Resume Next
'定义一个通用对话框commondg1 ，并邻接数据库
CommonDg1.Filter = "(shape)*.shp|*.shp|(all files)|*.*"
CommonDg1.ShowOpen
CommonDg1.InitDir = Left$(CommonDg1.filename, Len(CommonDg1.filename) - Len(CommonDg1.FileTitle) - 1)
dbconnction.Database = Left$(CommonDg1.filename, Len(CommonDg1.filename) - Len(CommonDg1.FileTitle) - 1)
dbconnction.Connect
Set lar.GeoDataset = dbconnction.FindGeoDataset(Left$(CommonDg1.FileTitle, Len(CommonDg1.FileTitle) - 4))
lar.Symbol.Color = moMagenta
'将图层添加到map1,map2中
Map1.Layers.Add lar
Map2.Layers.Add lar
Set lar = Nothing
'将map1,map2 刷新
Map1.Refresh
Map2.Refresh
'设置图例的源为map1,加载图例
legend1.setMapSource Map1
legend1.LoadLegend True
Set lars = Map1.Layers
'设置列表框list1 的初始值
Dim ofiled As MapObjects2.Field
If Not lars Is Nothing Then
For Each ofiled In Map1.Layers(0).Records.Fields
list1.AddItem ofiled.Name

 Next
End If
'begin with id num
list1.ListIndex = 0
End Sub

Private Sub mun_file_exit_Click()
'退出程序
End
End Sub

Private Sub mun_file_map_Click()
'输出当前map1中图
 CommonDgexport.Filter = "jpg(*.jpg)|*.jpg"
 CommonDgexport.DefaultExt = "jpg"
 CommonDgexport.filename = "zp.jpg"
 CommonDgexport.ShowSave
  Map1.ExportMapToJpeg CommonDgexport.filename, , True, , moAllSymbologyScaled
 
' Map1.ExportMapToJpeg App.Path & "\" & "zp.jpg", , True, , moAllSymbologyScaled
 
End Sub



Private Sub mun_help_aboat_Click()
'加载关于对话框 ，并显示
Load frmAbout
frmAbout.Show
End Sub

Private Sub mun_help_authour_Click()
'给我发e-mail ：zp2002gis2yahoo.com.cn
s = ShellExecute(0, "open", "mailto:[e-mail]", 0, 0, SW_SHOWNORMAL)
End Sub

Private Sub mun_help_content_Click()
'看帮助文件
 s = ShellExecute(0, "open", "E:\临时文件\zp.txt", 0, 0, SW_SHOWNORMAL)
End Sub

Private Sub mun_help_http_Click()
'打开我的主页 ：  http;//zp2002gis.home4u.china.com
 s = ShellExecute(0, "open", "http://zp2002gis.home4u.china.com", 0, 0, SW_SHOWNORMAL)
End Sub

Private Sub mun_layer_add_Click()
'添加图层
Dim addlayer As New MapObjects2.MapLayer
CommonDgaddlar.Filter = "(shape)*.shp|*.shp|(all files)|*.*"
CommonDgaddlar.InitDir = Left$(CommonDg1.filename, Len(CommonDg1.filename) - Len(CommonDg1.FileTitle) - 1)
CommonDgaddlar.ShowOpen
'dbconnction.Database = CurDir
'dbconnction.Connect
Set addlayer.GeoDataset = dbconnction.FindGeoDataset(Left$(CommonDgaddlar.FileTitle, Len(CommonDgaddlar.FileTitle) - 4))
addlayer.Symbol.Color = layercolor(icolor + 1).Color

 '用语判断是否图层加载重负
For Each lar In lars
If lar.Name = addlayer.Name Then
MsgBox "图层已经加载"
Else
Map1.Layers.Add addlayer
Map2.Layers.Add addlayer
Map2.Refresh
End If
Next



'Map1.Refresh
Set addlayer = Nothing
Set lars = Map1.Layers
icolor = icolor + 1
If icolor > 6 Then icolor = icolor - 1
'重设置图例legend1的源
legend1.setMapSource Map1
legend1.LoadLegend True
End Sub

Private Sub mun_layer_hide_Click()
 '隐藏所有当前图层
 Set lars = Map1.Layers
 For Each lar In lars
 lar.Visible = False
 Next
 Set lar = Nothing
 
 Map1.Refresh
  
 
End Sub

Private Sub mun_layer_remove_Click()
'删除当前图层
If Map1.Layers.Count >= 0 Then
'Map1.Layers.Clear
Do While (Map1.Layers.Count)
  Map1.Layers.Remove (Map1.Layers.Count - 1)
  
Loop
Map2.Layers.Clear
Else
MsgBox "没有图层了！"
End If
list1.Clear
Map1.Refresh
Map2.Refresh
 
set_legend1  '重设置图例legend1的源
dbconnction.Connect
End Sub

Private Sub mun_layer_show_Click()
 '设置当前的图层不可见 或者 可见
 Set lars = Map1.Layers
 For Each lar In lars
 lar.Visible = True
 Next
 Set lar = Nothing
 
 Map1.Refresh
End Sub

Private Sub mun_layer_tracking_add_Click()
 '初动态图层
begingtrackLar
End Sub

Private Sub mun_layer_tracking_addevent_Click()
 '设置鼠标的样式
flag = 8
Map1.MousePointer = moCross
End Sub