form1.frm

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

      
 '   ElseIf Toolbar1.Buttons("select").Value = 1 Then
  '     If g_LabelLayer.Selectrectangle(Map1.ToMapPoint(x, y)) = 0 Then
      ' 移动选定的矩形
   '   If Not g_LabelLayer.lblrectangle Is Nothing Then
   '   Set g_dragger = New DragFeedback
    '  g_dragger.DragStart g_LabelLayer.lblrectangle, Map1, x, y
   '   g_LabelLayer.Refresh
    '  Set m_ptfirst = Map1.ToMapPoint(x, y)
    '  End If
     'End If
    
 '   ElseIf Toolbar1.Buttons("spatial select").Value = 1 Then
  '
   '   Call frmSpatial.SelectFeatures(Button, Shift, x, y)
   '   frmSpatial.ZOrder 0
    
  End If
  End If
End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Dim curPoint As MapObjects2.Point
    Dim curX As Double
    Dim curY As Double
    '将屏幕坐标转化为地图坐标
    Set curPoint = Map1.ToMapPoint(X, Y)
    curX = curPoint.X
    curY = curPoint.Y
    '如果地图坐标过大，去掉小数点右边的数字
    Dim cX As String, cy As String
    cX = curX
    cy = curY
    cX = Left(cX, InStr(cX, ".") + 2)
    cy = Left(cy, InStr(cy, ".") + 2)
    StatusBar1.Panels(2).Text = "坐标 " & "X:" & cX & " Y:" & cy
End Sub

Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 If Not g_feedback Is Nothing Then
    g_feedback.DragMove X, Y
    End If
End Sub

Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not g_feedback Is Nothing Then
    Map1.Extent = g_feedback.DragFinish(X, Y)
    Set g_feedback = Nothing
  End If
End Sub

Private Sub mnuactivelayerextent_Click()
 doTask ("layer extent")
End Sub

Private Sub mnuarea_Click()
doTask ("measureA")
Toolbar1.Buttons("measureA").Value = tbrPressed

End Sub


Private Sub mnuAreaPartition_Click()

End Sub

Private Sub mnuAreaPartitionDatabase_Click()
Frmdata.Show
End Sub

Private Sub mnuattbrowse_Click()
Call frmatt.filllvwatt
frmatt.ZOrder 0
End Sub

Private Sub mnudist_Click()
Toolbar1.Buttons("measure").Value = tbrPressed
doTask ("measure")
End Sub

Private Sub mnuexplegend_Click()
On Err GoTo cancel
expbmpdialog.Filter = "windows bitmap(*.bmp)|*.bmp"
expbmpdialog.ShowSave
expbmpdialog.Flags = cdlOFNOverwritePrompt
'Or cdlOFNExplorer Or cdOFNLongNames

If Len(expbmpdialog.FileName) Then
   ' If map_index = 1 Then
    TuLi.ExportToBmp expbmpdialog.FileName
 '   Else
  '  legend2.ExportToBmp expbmpdialog.FileName
 
    
    frmview.Image1.Picture = LoadPicture(frmmain.expbmpdialog.FileName)
    frmview.Image1.Stretch = False

    frmview.Label1.Caption = "导出的图形文件: " & frmmain.expbmpdialog.FileName
    frmview.Label1.ZOrder 0
    frmview.Caption = "输出图例"
    
    frmview.VScroll1.Min = 0
    If (frmview.Image1.Height - frmview.Picture1.Height) > 0 Then
        frmview.VScroll1.Max = frmview.Image1.Height - frmview.Picture1.Height
        frmview.VScroll1.SmallChange = (frmview.Image1.Height - frmview.Picture1.Height) / 50
        frmview.VScroll1.LargeChange = (frmview.Image1.Height - frmview.Picture1.Height) / 10
    Else
        frmview.VScroll1.Enabled = False
    End If
    frmview.Show 1
End If
cancel:
End Sub



Private Sub mnuLandAnalysis_Click()
 If mnuLandAnalysis.Checked = False Then
 
        mnuLandAnalysis.Checked = True
        ' 加载图层
        Dim layer As New MapObjects2.MapLayer
            Dim dc As New MapObjects2.DataConnection
        dc.Database = App.path + "\" + "匡论文数据"
    If Not dc.Connect Then End
        Set layer = New MapLayer
        Set layer.GeoDataset = dc.FindGeoDataset("现状评价")
        layer.Symbol.style = moTransparentFill
        layer.Symbol.OutlineColor = moOrange
        Map1.Layers.Add layer
        legend1.setMapSource Map1
        legend1.LoadLegend True
        
'        Dim tbl As New MapObjects2.Table
'        tbl.Database = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.path & "\db\数据.mdb;"
'        tbl.name = "县域经济数据"
'        Map1.Layers("省地县中原城市群1").RemoveRelates
'        Map1.Layers("省地县中原城市群1").AddRelate "id", tbl, "id"

      Set g_activelayer = Map1.Layers("省地县中原城市群1")
'        frmLayerSymbol.sstLayerProp.Tab = 2
'        frmLayerSymbol.Show vbModal
'    Else
''        Dim Index As Long
'        Dim i As Integer
'        For i = 0 To Map1.Layers.Count - 1
'             If Map1.Layers(i).name = "噪声分布" Then
'                 Index = i
'                 Exit For
'            End If
'        Next i
'        Map1.Layers(Index).RemoveRelates
'        Map1.Layers.Remove Index
'        legend1.setMapSource Map1
'        legend1.LoadLegend True
       
    FrmDatabaseSelect.Show
  Else
     Dim Index As Long
        Dim i As Integer
        For i = 0 To Map1.Layers.Count - 1
             If Map1.Layers(i).Name = "噪声分布" Then
                 Index = i
                 Exit For
            End If
        Next i
        Map1.Layers(Index).RemoveRelates
        Map1.Layers.Remove Index
        legend1.setMapSource Map1
        legend1.LoadLegend True
   mnuDistributing.Checked = False
    End If
End Sub

Private Sub mnulayeradd_Click()

Call AddFile
Dim i As Integer
For i = 0 To Map1.Layers.Count - 1
  TuLi.Active(i) = False

Next i
End Sub

Private Sub mnulayermapproperties_Click()
 Call doTask("map properties")
End Sub

Private Sub mnulgappeargraphic_Click()
mnulgappeargraphic.Visible = False
End Sub

Private Sub mnulayerproperties_Click()

Dim Index As Integer
 Index = TuLi.getActiveLayer
  
  If Index = -1 Then
    MsgBox "当前没有活动图层！", vbCritical, "停止"
    Exit Sub
  End If
  
  Set g_activelayer = Map1.Layers(Index)
  
  If Map1.Layers(Index).LayerType = moImageLayer Then
    MsgBox "Sorry, you cannot set properties for an image layer.", _
           vbCritical, "Stop"
    Exit Sub
  End If
frmLayerSymbol.Caption = "图层属性"
  'Invoke property sheet for new layer.
  frmLayerSymbol.Show vbModal


End Sub

Private Sub mnuprjexpbmp_Click()
 ExportBMP Map1
 If Len(expbmpdialog.FileName) Then
    frmview.Label1.Caption = "导出的图形文件: " & expbmpdialog.FileName
     frmview.Image1.Picture = LoadPicture(expbmpdialog.FileName)
    frmview.Image1.Stretch = True
    frmview.VScroll1.Enabled = False
    frmview.Show 1
  Else
  MsgBox "没有文件输出"
  End If
End Sub

Private Sub mnuprjprint_Click()
frmPrint.Show
End Sub

Private Sub mnuprjprintset_Click()
CommonDialog1.Flags = cdlPDPrintSetup
CommonDialog1.ShowPrinter
End Sub

Private Sub mnuprjsendtoclip_Click()
 Map1.CopyMap 1
End Sub

Private Sub mnuQuhuaAnalysis_Click()
frmSingleEvaluate.Show

End Sub

Private Sub mnuRemoveAllLayers_Click()
'Clear the Layers collection
  Map1.Layers.Clear
  Map2.Layers.Clear
  'Clear the Main form's scale status area
 ' Call updateScale
  TuLi.LoadLegend
  frmmain.Refresh
  'Update the MapTip layer and field values in the combo boxes.
 ' If frmmain.ChkTiplayer.Value = 1 Then refreshMapTips
End Sub

Private Sub mnuremovelayer_Click()
If Not Map1.Layers.Count = 0 Then
  Dim Index As Long
  Index = TuLi.getActiveLayer
  If Index <> -1 Then
    Map1.Layers.Remove Index
    'Map2.Layers.Remove Index
    TuLi.LoadLegend   'Refresh legend
   Else
    MsgBox "当前地图没有被激活的图层", vbCritical, "停止"
    Exit Sub
  End If
End If
If Map1.Layers.Count = 0 Then
    Map2.Layers.Clear
End If
  'Update the MapTip layer and field values in the combo boxes.
'  If frmmain.ChkTiplayer.Value = 1 Then refreshMapTips
End Sub

Private Sub mnuselectobject_Click()
 Toolbar1.Buttons("identify").Value = tbrPressed
   Call doTask("identify")
End Sub

Private Sub mnuseteditspatial_Click()
 frmattedit.showfrmattedit
End Sub

Private Sub mnuSpatialOutput_Click()
  Toolbar1.Buttons("spatial select").Value = tbrPressed
    frmSpatial.Show
    Map1.MousePointer = moArrow
End Sub

Private Sub mnuviewcleargraphics_Click()
 Map1.TrackingLayer.ClearEvents
    Set collGtextStrings = Nothing
    Set collGtextline = Nothing
    Map1.TrackingLayer.Refresh True
End Sub

Private Sub mnuviewfull_Click()
 Call doTask("full extent")
End Sub

Private Sub mnuviewlast_Click()
Call doTask("movelast")
End Sub

Private Sub mnuviewnext_Click()
Call doTask("movenext")
End Sub

Private Sub mnuviewpan_Click()
 frmmain.Toolbar1.Buttons("pan").Value = tbrPressed
    Call doTask("pan")

End Sub

Private Sub mnuviewzoomin_Click()
frmmain.Toolbar1.Buttons("zoom in").Value = tbrPressed
  Call doTask("zoom in")
End Sub

Private Sub mnuviewzoomout_Click()
frmmain.Toolbar1.Buttons("zoom out").Value = tbrPressed
  Call doTask("zoom out")
End Sub

Private Sub mnuviwdrawgraphics_Click()
Toolbar1.Buttons("graphics").Value = 1
  Call doTask("graphics")
End Sub

Private Sub mnuWaterAnalysis_Click()
If mnuWaterAnalysis.Checked = False Then
   mnuWaterAnalysis.Checked = True
 
       
        ' 加载图层
        Dim layer As New MapObjects2.MapLayer
            Dim dc As New MapObjects2.DataConnection
        dc.Database = App.path + "\" + "分析数据"
    If Not dc.Connect Then End
        Set layer = New MapLayer
        Set layer.GeoDataset = dc.FindGeoDataset("水资源")
        layer.Symbol.style = moTransparentFill
        layer.Symbol.OutlineColor = moDarkGreen
       '  molyr.Symbol.Color = moNavy
   '  molyr.Symbol.Size = 5
    ' molyr.Symbol.style = 0
        
        Map1.Layers.Add layer
        Map2.Layers.Add layer
        TuLi.setMapSource Map1
        TuLi.LoadLegend True
        
'        Dim tbl As New MapObjects2.Table
'        tbl.Database = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.path & "\db\数据.mdb;"
'        tbl.name = "县域经济数据"
'        Map1.Layers("省地县中原城市群1").RemoveRelates
'        Map1.Layers("省地县中原城市群1").AddRelate "id", tbl, "id"

       Set g_activelayer = Map1.Layers("水资源")
       frmLayerSymbol.sstLayerProp.Tab = 2
     frmLayerSymbol.Show vbModal
'    Else
''        Dim Index As Long
'        Dim i As Integer
'        For i = 0 To Map1.Layers.Count - 1
'             If Map1.Layers(i).name = "噪声分布" Then
'                 Index = i
'                 Exit For
'            End If
'        Next i
'        Map1.Layers(Index).RemoveRelates
'        Map1.Layers.Remove Index
'        legend1.setMapSource Map1
'        legend1.LoadLegend True
       
 '   FrmDatabaseSelect.Show
 'Else
  '   Dim Index As Long
   '     Dim i As Integer
    '    For i = 0 To Map1.Layers.Count - 1
     '        If Map1.Layers(i).Name = "噪声分布" Then
      '           Index = i
       '          Exit For
        '    End If
      '  Next i
    '    Map1.Layers(Index).RemoveRelates
     '   Map1.Layers.Remove Index
      '  legend1.setMapSource Map1
       ' legend1.LoadLegend True
 '  mnuWaterAnalysis.Checked = False
 End If
End Sub

Private Sub print_Click()

End Sub

Private Sub query_Click()
frmintegraEvaluate.Show vbModal
End Sub

Private Sub Splitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Splitter.MousePointer = moSizeWE
If Button = 1 Then
  Splitter.Left = Splitter.Left + X
  If Splitter.Left > 350 Then
     Splitter.Refresh
    frmmain.Refresh
   Else
Splitter.Left = 350
Splitter_MouseUp Button, Shift, X, Y
  End If
End If
End Sub

Private Sub Splitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Splitter.BackColor = frmmain.BackColor
TuLi.Width = Splitter.Left



Map1.Left = Splitter.Left + Splitter.Width
If Me.ScaleWidth > TuLi.Width + Splitter.Width + 50 Then
Map1.Width = Me.ScaleWidth - TuLi.Width - Splitter.Width - 50
End If

'With Map3
 '   .Left = Map1.Left
  '  .Width = Map1.Width
'End With

Map2.Width = TuLi.Width

'splliter.Width = TabStrip1.Width

'picSplitter.ZOrder 1
       
'If map_index = 1 Then
 
 '   Map1.Visible = True
  '  Map2.Visible = True
   ' With legend1
    '.Visible = True
'    .ZOrder 0
  '  End With
    
   ' Map3.Visible = False
  '  Map4.Visible = False
   ' legend2.Visible = False

'Else
 '   Map1.Visible = False
  '  Map2.Visible = False
   ' legend1.Visible = False
    
  '  Map3.Visible = True
   ' Map4.Visible = True
    'legend2.Visible = True

'End If
End Sub


 
         
'在Map2上画红色指示框；
Private Sub Map2_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
  Dim sym As New Symbol
      sym.OutlineColor = moRed
    sym.Size = 2
    sym.style = moTransparentFill
    Map2.DrawShape Map1.Extent, sym