form1.frm

用于河南省主体功能区区划的一个小地理信息系统

      End
      Begin VB.Menu mnuexplegend 
         Caption         =   "输出图例"
      End
      Begin VB.Menu mnuprjsplit2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuprjprintset 
         Caption         =   "打印设置"
      End
      Begin VB.Menu mnuprjprint 
         Caption         =   "打印(&P)"
      End
      Begin VB.Menu mnuprjsplit3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuprjexit 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu mnuview 
      Caption         =   "视图(&V)"
      Begin VB.Menu mnuviewzoomin 
         Caption         =   "地图放大(&O)"
      End
      Begin VB.Menu mnuviewzoomout 
         Caption         =   "地图缩小(&I)"
      End
      Begin VB.Menu mnuviewpan 
         Caption         =   "漫游(&P)"
      End
      Begin VB.Menu mnuviewfull 
         Caption         =   "全图显示(&A)"
      End
      Begin VB.Menu mnuviewsplit1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuviewlast 
         Caption         =   "上级视图(&F)"
      End
      Begin VB.Menu mnuviewnext 
         Caption         =   "下级视图(&N)"
      End
      Begin VB.Menu mnuviewsplit2 
         Caption         =   "-"
      End
      Begin VB.Menu mnudist 
         Caption         =   "距离量算"
      End
      Begin VB.Menu mnuarea 
         Caption         =   "面积测量(&P)"
      End
   End
   Begin VB.Menu mnulayer 
      Caption         =   "图层(&L)"
      Begin VB.Menu mnulayeradd 
         Caption         =   "添加图层"
      End
      Begin VB.Menu mnulayersplitter1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuremovelayer 
         Caption         =   "移去当前图层"
      End
      Begin VB.Menu mnuRemoveAllLayers 
         Caption         =   "移去所有图层"
      End
      Begin VB.Menu mnulayersplitter2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuSpatialOutput 
         Caption         =   "选择输出(&S)"
      End
      Begin VB.Menu mnulayersplitter3 
         Caption         =   "-"
      End
      Begin VB.Menu mnulayermapproperties 
         Caption         =   "地图属性(&M)"
      End
      Begin VB.Menu mnulayersplitter4 
         Caption         =   "-"
      End
      Begin VB.Menu mnulayerproperties 
         Caption         =   "图层属性"
      End
   End
   Begin VB.Menu MenuQuery 
      Caption         =   "数据查询和统计"
      Begin VB.Menu mnuattbrowse 
         Caption         =   "属性浏览(&B)"
      End
      Begin VB.Menu mnuselectobject 
         Caption         =   "实体查询(&E)"
      End
      Begin VB.Menu mnuquerysplitter1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuStationary 
         Caption         =   "数据统计"
      End
   End
   Begin VB.Menu mnuQuhuaAnalysis 
      Caption         =   "区划单项指标项计算评价"
   End
   Begin VB.Menu query 
      Caption         =   "区划指标项综合计算评价"
   End
   Begin VB.Menu mnuDatabaseManger 
      Caption         =   "数据库管理"
      Begin VB.Menu mnuAreaPartitionDatabase 
         Caption         =   "区划数据库"
      End
      Begin VB.Menu mnuDatabaseMangersplitter1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuseteditspatial 
         Caption         =   "空间数据库"
      End
   End
   Begin VB.Menu managerEnter 
      Caption         =   "系统管理员登陆"
   End
   Begin VB.Menu help 
      Caption         =   "帮助"
   End
End
Attribute VB_Name = "frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public map_index As Integer
'Public m_maptip As New MapTip
Public g_activelayer As Object

'定义标注对象
'Public g_LabelLayer As New LabelLayer

Private collGtextStrings As New VBA.Collection
Private collGtextline As New VBA.Collection
Private symGtext As New MapObjects2.TextSymbol
Private collGtextStrings2 As New VBA.Collection
Private collGtextline2 As New VBA.Collection

Dim isbrow As Integer

' dragging variables
Dim g_dragger As DragFeedback

'对放大、缩小时矩形、图形显示、矩形中心点定义
Dim rect As MapObjects2.Rectangle
Dim newrect As MapObjects2.Rectangle
Dim pt As New MapObjects2.Point

'定义标签移动时的初始点
Dim m_ptfirst As MapObjects2.Point, m_ptfinal As MapObjects2.Point

Dim node0, nodeX As Node

Private BarState As String

Private Const MIN_LEGEND_WIDTH = 350
Private Const INCH2FEET = 12
Private Const INCH2METERS = 39.37
Private Const INCH2DEGREES = 4322893.46
'显示飞机大小
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
Dim sym_airport As New MapObjects2.Symbol
'建筑物周围道路噪声分布
Public WnsourceL As New MapObjects2.Line
Public Wnbarrierrec As MapObjects2.Recordset
'浏览帮助文件
Dim viewlaw As Boolean
'改变建筑物高度
Dim changeBuildH As Boolean

Public LastState As Integer '托盘程序
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&
Dim r As MapObjects2.Rectangle

Public strMapUnits As String
Dim g_feedback As DragFeedback


'添加图层
Sub AddLyrLegend()
 Dim molyr As New MapObjects2.MapLayer
    Dim moDc As New MapObjects2.DataConnection
    
    moDc.Database = App.path + "\" + "匡论文数据"
   ' moDc.Database = ReturnDataPath("匡论文数据")
    If Not moDc.Connect Then
    MsgBox "没有找到当前文件夹", vbCritical, "主体功能区区划系统"
    Exit Sub
    End If
    
     Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("河南县界")
    molyr.Symbol.Color = moYellow
        molyr.Symbol.Size = 1
     molyr.Symbol.style = 0
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
    
        
      Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("铁路")
    molyr.Symbol.Color = moDarkGray
      molyr.Symbol.Size = 1
     molyr.Symbol.style = 0
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
    
    
     Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("高速路")
    molyr.Symbol.Color = moBlue
     molyr.Symbol.Size = 1
     molyr.Symbol.style = 0
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
    
      Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("水系")
    molyr.Symbol.Color = moCyan
     molyr.Symbol.Size = 1.5
     molyr.Symbol.style = 0
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
    
    
   
    Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("地市")
     molyr.Symbol.Size = 5
     molyr.Symbol.style = 0
    molyr.Symbol.Color = moRed
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
    'molyr.Visible = False
 
    
   
   
    
    Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("港口")
    molyr.Symbol.Color = moNavy
     molyr.Symbol.Size = 5
     molyr.Symbol.style = 0
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
   
    
     Set molyr = New MapLayer
    Set molyr.GeoDataset = moDc.FindGeoDataset("机场")
    molyr.Symbol.Color = moTeal
     molyr.Symbol.Size = 5
     molyr.Symbol.style = 1
    Map1.Layers.Add molyr
    Map2.Layers.Add molyr
   
   
    
    TuLi.setMapSource Map1
    TuLi.LoadLegend True
   Map1.Refresh
  Map2.Refresh
      
 
End Sub


Private Sub Form_Load()
 On Error Resume Next
 Call AddLyrLegend
  Me.KeyPreview = True
 Me.Icon = LoadPicture(App.path & "\Bitmaps\earth.ico")
  strMapUnits = "Meters"

End Sub

Private Sub Form_Resize()

If Me.ScaleHeight > 450 + StatusBar1.Height And Me.ScaleWidth > TuLi.Width + Splitter.Width + 100 Then
    With TuLi
         .Height = Me.ScaleHeight * 73 / 110
         .Left = 100
         .Top = Toolbar1.Height + 100
     End With
'Toolbar1.Height = 500
  With Map1
    .Top = TuLi.Top
    .Height = Me.ScaleHeight - Toolbar1.Height - StatusBar1.Height
    .Width = Me.ScaleWidth - TuLi.Width - Splitter.Width
    .Left = TuLi.Left + TuLi.Width + Splitter.Width
 End With
  
  With Map2
      .Top = TuLi.Top + TuLi.Height + 100
      .Left = TuLi.Left
      .Height = Me.ScaleHeight * 15 / 60
      .Width = TuLi.Width
     End With
StatusBar1.Top = Map2.Top + Map2.Height
StatusBar1.Height = frmmain.Height * 7 / 200
 With Splitter
   .Left = TuLi.Left + TuLi.Width
   .Height = Map1.Height
   .Width = 200
   .Top = Map1.Top
   End With
'StatusBar.Panels(3).Bevel = sbrNoBevel
'StatusBar.Panels(6).Bevel = sbrNoBevel

'StatusBar.Panels(4).Text = "坐标："

'StatusBar.Panels(1).Width = 200
'StatusBar.Panels(3).Width = 1000
'StatusBar.Panels(4).Width = 2500
'StatusBar.Panels(5).Width = 3000
'StatusBar.Panels(6).Width = Map1.Width * 3 / 48
'StatusBar.Panels(2).AutoSize = sbrContents
'StatusBar.Panels(8).Width = 1200

'legend.Top = SSTab.Top


End If

End Sub



Private Sub ExportBMP(m_map As MapObjects2.Map)
  
  On Error Resume Next
  expbmpdialog.DialogTitle = "输出为bmp文件"
  expbmpdialog.Filter = "windows bitmap(*.bmp)|*.bmp"
expbmpdialog.Flags = cdlOFNOverwritePrompt
 'Or cdlOFNExplorer Or cdOFNLongNames
  expbmpdialog.ShowSave    '(Me.hWnd, "Windows Bitmap (*.bmp)" & vbNullChar & "*.bmp" & vbNullChar & vbNullChar, "输出到文件", "BMP")
  If Err > 0 Then Exit Sub
  If Len(expbmpdialog.FileName) Then
    m_map.ExportMap moExportBMP, expbmpdialog.FileName, 1
  End If
    
  'Set expbmpdialog = Nothing
End Sub

Private Sub managerEnter_Click()
guanliyuandenglu.Show

End Sub

Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hDC As stdole.OLE_HANDLE)
 If Index = 0 Then
    Map2.TrackingLayer.Refresh True
  End If

   
End Sub

Private Sub Map1_BeforeLayerDraw(ByVal Index As Integer, ByVal hDC As stdole.OLE_HANDLE)
Call updateScale
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
If Button = 1 Then
        
  If Toolbar1.Buttons("measure").Value = 1 Then
          '测距
        Dim distln As Object
       Set distln = Map1.TrackLine
       MsgBox "米：" & Format(distln.Length, "#,##0.00"), vbOKOnly, "测量距离"
       Map1.Refresh
       Toolbar1.Buttons("measure").Value = 0
       
   ElseIf Toolbar1.Buttons("measureA").Value = 1 Then
        Dim PArea As MapObjects2.Polygon
        Set PArea = Map1.TrackPolygon
        MsgBox "面积：" & Format(PArea.Area, "#,##0.00") + vbCrLf + "周长：" _
           & Format(PArea.Perimeter, "#,##0.00"), , "测量面积"
        Map1.Refresh
       Toolbar1.Buttons("measureA").Value = 0
    ElseIf Toolbar1.Buttons("identify").Value = 1 Then
  
      Call FrmIdentify.Identify(X, Y)
      FrmIdentify.ZOrder 1
      ElseIf Toolbar1.Buttons("zoom in").Value = tbrPressed Then
           
              Call dozoomin(Map1)
'       Set pt = rect.Center
'
'       Map1.CenterAt pt.X, pt.Y
        Dim mapextent As New MapObjects2.Rectangle
        Set mapextent = Map1.Extent
  
          If M_extent.Count < 5 Then
            M_extent.Add mapextent
          Else
            M_extent.Remove 1
            M_extent.Add mapextent
        End If
        M_K = M_extent.Count
        mnuviewlast.Enabled = True
        Toolbar1.Buttons("movelast").Enabled = True
     
     '设置这个是防止这个操作干扰到其他操作，比如：点完放大后再量距离，有干扰
    '在视图放大菜单中设置为了tbrPressed，则程序运行到这里再会执行放大操作了，
    '不会执行量距离了
   
    
    ElseIf Toolbar1.Buttons("zoom out").Value = 1 Then    'tbrUnpressed相当于0，tbrPressed相当于1
           
        Call dozoomout(Map1)
        'Set pt = rect.Center
        'Map1.CenterAt pt.X, pt.Y
        Set mapextent = Map1.Extent
  
        If M_extent.Count < 5 Then
            M_extent.Add mapextent
        Else
            M_extent.Remove 1
            M_extent.Add mapextent
        End If
        M_K = M_extent.Count
        mnuviewlast.Enabled = True
        Toolbar1.Buttons("movelast").Enabled = True
      
    
    ElseIf Toolbar1.Buttons("pan").Value = 1 Then
      
       Map1.Pan
       'Map1.MousePointer = moPan
        Set mapextent = Map1.Extent
  
        If M_extent.Count < 5 Then
            M_extent.Add mapextent
        Else
            M_extent.Remove 1
            M_extent.Add mapextent
        End If
        M_K = M_extent.Count
        mnuviewlast.Enabled = True
        frmmain.Toolbar1.Buttons("movelast").Enabled = True
         Toolbar1.Buttons("pan").Value = tbrUnpressed
       
   ElseIf Toolbar1.Buttons("full extent").Value = 1 Then
     Toolbar1.Buttons("full extent").Value = 0
     Set Map1.Extent = Map1.FullExtent
    
   ElseIf Toolbar1.Buttons("movelast").Value = 1 Then
     Toolbar1.Buttons("movelast").Value = 0
             Map1.MousePointer = moDefault
             Call doTask("movelast")
             
  ElseIf Toolbar1.Buttons("movenext").Value = 1 Then
        Toolbar1.Buttons("movenext").Value = 0
       Map1.MousePointer = moDefault
       Call doTask("movenext")
  '  ElseIf Toolbar1.Buttons("label").Value = 1 Then
   '   'getactivelayer
    '  Dim Index As Integer
    '  Index = legend1.getActiveLayer
    '  If Index > -1 Then
    '  If Map1.Layers(Index).Visible = True Then
    '  Set g_activelayer = Map1.Layers(Index)
    '  g_LabelLayer.Add g_activelayer, "名称", Map1.ToMapPoint(x, y)
    '  End If
    '  End If