dockfind.frm

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Begin VB.Form frmLayer 
   BorderStyle     =   0  'None
   Caption         =   "图层控制"
   ClientHeight    =   8565
   ClientLeft      =   105
   ClientTop       =   405
   ClientWidth     =   2565
   Icon            =   "DockFind.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   8565
   ScaleWidth      =   2565
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin MSComctlLib.TreeView treeLayer 
      DragIcon        =   "DockFind.frx":08A6
      Height          =   4215
      Left            =   0
      TabIndex        =   1
      Top             =   120
      Width           =   2535
      _ExtentX        =   4471
      _ExtentY        =   7435
      _Version        =   393217
      Indentation     =   0
      LabelEdit       =   1
      LineStyle       =   1
      Style           =   7
      Checkboxes      =   -1  'True
      SingleSel       =   -1  'True
      ImageList       =   "LayerIcon"
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin MapObjects2.Map Map2 
      Height          =   2415
      Left            =   0
      TabIndex        =   0
      Top             =   3240
      Width           =   2535
      _Version        =   131072
      _ExtentX        =   4471
      _ExtentY        =   4260
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Appearance      =   1
      ScrollBars      =   0   'False
      FullRedrawOnPan =   -1  'True
      Contents        =   "DockFind.frx":09F0
   End
   Begin MSComctlLib.ImageList LayerIcon 
      Left            =   1560
      Top             =   6720
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   3
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "DockFind.frx":0A0A
            Key             =   "!Group!"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "DockFind.frx":0D5D
            Key             =   "Enable"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "DockFind.frx":10B0
            Key             =   "Disable"
         EndProperty
      EndProperty
   End
   Begin VB.PictureBox Movebar 
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   100
      Left            =   0
      MousePointer    =   7  'Size N S
      ScaleHeight     =   105
      ScaleWidth      =   2535
      TabIndex        =   2
      Top             =   6000
      Width           =   2535
   End
   Begin VB.Menu mnuLabel 
      Caption         =   "显示标注"
      Begin VB.Menu mnuVisible 
         Caption         =   "隐藏标注"
      End
   End
End
Attribute VB_Name = "frmLayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim indrag As Boolean '指示拖放操作的标志。
Dim nodX As Object '要拖动的项。
Dim lButton As Boolean
Dim bMove As Boolean
Dim LastX As Single
Dim LastY As Single

Public Sub Resize()

Call Form_Resize
End Sub
Private Sub Form_Resize()

'------------------------------------------------------------------------------------
'当窗体大小改动时，相应改动内部的控件大小
'------------------------------------------------------------------------------------
'
On Error Resume Next

Map2.Width = frmLayer.ScaleWidth
Movebar.Width = frmLayer.ScaleWidth
treeLayer.Width = frmLayer.ScaleWidth

Partition = (frmLayer.ScaleHeight - Movebar.Height - Map2.Height) / frmLayer.ScaleHeight

If Map2.Visible Then
    treeLayer.Height = frmLayer.ScaleHeight - Movebar.Height - Map2.Height - 50
Else
    treeLayer.Height = frmLayer.ScaleHeight
End If

Movebar.Top = Partition * frmLayer.ScaleHeight

Map2.Top = frmLayer.ScaleHeight - Map2.Height  'Movebar.Top + Movebar.Height
frmMain.FraZoom.Left = frmLayer.Left + frmLayer.Width + 200


End Sub
Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
  ' 画一个矩形以表示现在map1中正显示的内容
  Dim sym As New Symbol
  sym.OutlineColor = moRed
  sym.Style = moTransparentFill
  Map2.DrawShape frmMain.Map1.Extent, sym
End Sub

Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  
  '转换到map中的点
  Dim p As MapObjects2.POINT
  Set p = Map2.ToMapPoint(x, Y)
  
  ' 如果鼠标点在矩形内部，则开始拖动操作
  If frmMain.Map1.Extent.IsPointIn(p) Then
    Set frmMain.g_feedback = New DragFeedback
    frmMain.g_feedback.DragStart frmMain.Map1.Extent, Map2, x, Y
  End If
End Sub

Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
  
  If Not frmMain.g_feedback Is Nothing Then
    '拖拽中
    frmMain.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 frmMain.g_feedback Is Nothing Then
    '拖拽完毕
    frmMain.Map1.Extent = frmMain.g_feedback.DragFinish(x, Y)
    Set frmMain.g_feedback = Nothing
  End If
End Sub

Private Sub mnuCleanLayer_Click()
Call NewFile
End Sub

Private Sub mnuEnMap_Click()
'------------------------------------------------------------------------------------
'图层的显示与隐藏
'------------------------------------------------------------------------------------
If treeLayer.SelectedItem Is Nothing Then Exit Sub
Dim LayerX As MapLayer
Set LayerX = frmMain.Map1.Layers(treeLayer.SelectedItem.Key)

If mnuEnMap.Caption = "显示图层" Then
    'CustomLayers(NameToIndex(treeLayer.SelectedItem.Key)).bVisibleInMainMap = True
    mnuEnMap.Caption = "隐藏图层"
    LayerX.Visible = True
Else
    'CustomLayers(NameToIndex(treeLayer.SelectedItem.Key)).bVisibleInMainMap = False
    mnuEnMap.Caption = "显示图层"
    LayerX.Visible = False
End If
frmMain.Map1.Refresh

End Sub

Private Sub mnuEnOver_Click()
'------------------------------------------------------------------------------------
'缩略图的显示与隐藏
'------------------------------------------------------------------------------------
If treeLayer.SelectedItem Is Nothing Then Exit Sub
Dim LayerX As MapLayer
Set LayerX = Map2.Layers(treeLayer.SelectedItem.Key)
If mnuEnOver.Caption = "显示缩略图" Then
    mnuEnOver.Caption = "隐藏缩略图"
   
    LayerX.Visible = True
    
Else
    mnuEnOver.Caption = "显示缩略图"
    
    LayerX.Visible = False
End If
Map2.Refresh
End Sub

Private Sub mnuVisible_Click()
    Dim LayerX As MapLayer
    Set LayerX = frmMain.Map1.Layers(mnuLabel.Caption)
    If mnuVisible.Caption = "显示标注" Then
        Dim RendererX As New LabelRenderer
        RendererX.Field = CustomLayers(NameToIndex(mnuLabel.Caption)).strLabelField
        RendererX.Symbol(0).Font.Bold = False
        Set LayerX.Renderer = RendererX
        mnuVisible.Caption = "隐藏标注"
    Else
        Set LayerX.Renderer = Nothing
        mnuVisible.Caption = "显示标注"
    End If
    frmMain.Map1.Refresh
End Sub

Private Sub Movebar_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

'------------------------------------------------------------------------------------
'窗口比例调整开始
'------------------------------------------------------------------------------------
    Map2.Visible = False
    bMove = True
    LastX = x
    LastY = Y
    
End Sub

Private Sub Movebar_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)

'------------------------------------------------------------------------------------
'正在进行窗口比例调整
'------------------------------------------------------------------------------------
    If bMove Then
        '防止子窗口过小造成溢出
        If LastY - Y > 0 Then
            If treeLayer.Height < 400 Then Exit Sub
        Else
            If Map2.Height < 200 Then Exit Sub
        End If
        
        treeLayer.Height = treeLayer.Height - LastY + Y
        Movebar.Top = Movebar.Top - LastY + Y
        Map2.Height = frmLayer.ScaleHeight - treeLayer.Height - Movebar.Height - 50
        Map2.Top = Map2.Top - LastY + Y
        Partition = treeLayer.Height / frmLayer.ScaleHeight
        
    End If
        
End Sub

Private Sub Movebar_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
'------------------------------------------------------------------------------------
'窗口比例调整结束
'------------------------------------------------------------------------------------
    If bMove Then
        bMove = False '
        Map2.Visible = True
    End If
End Sub


Private Sub treeLayer_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If Button = vbRightButton Then
    If Not treeLayer.HitTest(x, Y) Is Nothing Then
        Set treeLayer.SelectedItem = treeLayer.HitTest(x, Y)
        If Not fnIsGroup(treeLayer.SelectedItem.Key) Then
            If CustomLayers(NameToIndex(treeLayer.SelectedItem.Key)).strLabelField <> "" Then
                mnuLabel.Caption = treeLayer.SelectedItem.Key
                PopupMenu mnuLabel
            End If
        End If
    End If
    
End If


End Sub
Private Sub treeLayer_NodeClick(ByVal Node As MSComctlLib.Node)
With frmMain.abProMap.Bands("barStandard").Tools("cmbWork")
    Dim lpField As Long
    For lpField = 0 To .CBListCount - 1
        If .CBList(lpField) = Node.Key Then
            .CBListIndex = lpField
            Exit For
        End If
    Next lpField
    
End With
End Sub
'鼠标单击节点的CheckBox事件响应代码
Private Sub treeLayer_NodeCheck(ByVal Node As MSComctlLib.Node)

If fnIsGroup(Node.Key) Then
    '单击的是分组节点，则此分组下所有图层全部改变可视状态
    Dim lpLayer As Long
    Dim LayerX As MapLayer
    With LayerGroup(NameToGroupIndex(Mid(Node.Key, 8)))
        For lpLayer = 0 To .lLayerCount - 1
            Set LayerX = frmMain.Map1.Layers(.lLayerIndex(lpLayer))
            '判断图层是否在图例中有显示
            If ExistInTree(LayerX.Name) Then
                LayerX.Visible = Node.Checked
                treeLayer.Nodes(LayerX.Name).Checked = Node.Checked
            End If
        Next lpLayer
    End With
Else
    '单击的是图层节点，则只需要改变相应图层的可视状态
    frmMain.Map1.Layers(Node.Key).Visible = Node.Checked
End If
frmMain.Map1.Refresh

End Sub

Private Function ExistInTree(nodeName As String) As Boolean
'判断某个节点是否存在于图例中
    Dim strTemp As String
On Error GoTo NoExist
    strTemp = treeLayer.Nodes(nodeName).Key
    ExistInTree = True
    Exit Function
NoExist:
    ExistInTree = False
End Function

Private Function fnIsGroup(strName As String) As Boolean
'判断某个节点是否是分组节点
    If Len(strName) < Len("!Group!") + 1 Then
        fnIsGroup = False
    Else
        If Mid(strName, 1, Len("!Group!")) = "!Group!" Then
            fnIsGroup = True
        Else
            fnIsGroup = False
        End If
    End If

End Function