frmmain.frm

地图查询 鹰眼 放大 缩小 vb mapx

      DefaultStyle.RegionBackColor=   16777215
      DefaultStyle.RegionBorderStyle=   1
      DefaultStyle.RegionBorderWidth=   1
      HasProjectionInfo=   -1  'True
      NumericCoordsys =   "Frmmain.frx":71D5
      DisplayCoordsys =   "Frmmain.frx":7305
      NumDatasets     =   0
      TitleX          =   5000
      TitleY          =   1000
      TitleVisible    =   0   'False
      TitleEditable   =   -1  'True
      TitlePostiion   =   0
      TitleBorder     =   -1  'True
   End
   Begin VB.Frame Frame2 
      Caption         =   "查询显示"
      Height          =   5055
      Left            =   0
      TabIndex        =   9
      Top             =   3840
      Width           =   2775
   End
   Begin VB.Label Label1 
      BackColor       =   &H00808000&
      Caption         =   "点击此处查询全国土地分等结果（请稍等，调动文件速度较慢）"
      Height          =   495
      Left            =   0
      TabIndex        =   10
      Top             =   3360
      Width           =   2775
   End
   Begin ComctlLib.ImageList ImageList1 
      Left            =   10800
      Top             =   480
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} 
         NumListImages   =   10
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":7435
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":760F
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":77E9
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":79C3
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":7CDD
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":802F
            Key             =   ""
         EndProperty
         BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":8381
            Key             =   ""
         EndProperty
         BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":86D3
            Key             =   ""
         EndProperty
         BeginProperty ListImage9 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":88AD
            Key             =   ""
         EndProperty
         BeginProperty ListImage10 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "Frmmain.frx":8A87
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Menu menufile 
      Caption         =   "文件"
      Begin VB.Menu menuback 
         Caption         =   "返回首页"
      End
   End
End
Attribute VB_Name = "Frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Path$
Dim a$(10)
'定义DB数据对象，dbl为表对象，mmm为表“中国”记录的个数
'Dim db As Database, dbl As Recordset, mmm As Integer

Dim m_Layer As Layer     '鹰眼图上临时图层
Dim m_Fea As MapXLib.Feature   '鹰眼图上反映主地图窗口位置的Feature
Private FormOldWidth     As Long
  '保存窗体的原始宽度
  Private FormOldHeight     As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public ftr As MapXLib.Feature
Public lyr As MapXLib.Layer
Public kk As Boolean

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
    '改变treeview2背景
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    '改变treeview2背景
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    '改变treeview2背景
  Private Const GWL_STYLE = -16& '改变treeview2背景
  Private Const TVM_SETBKCOLOR = 4381& '改变treeview2背景
  Private Const TVM_GETBKCOLOR = 4383& '改变treeview2背景
  Private Const TVS_HASLINES = 2& '改变treeview2背景

Dim frmlastForm     As Form '改变treeview2背景
    


Dim p As Picture

Private Sub Command1_Click()
Dim lyr As MapXLib.Layer
Dim ds As MapXLib.Dataset
Dim ss As Boolean

Dim ftrs As MapXLib.Features
Dim ftr As MapXLib.Feature
Dim bb As Integer
Dim aa As Integer

Map1.Bounds = Map1.Layers.Bounds
If List2.Text = "" Then

aa = MsgBox("请选择要查询的地区", vbOKOnly, "提示")
Else: Set lyr = Map1.Layers(List1.Text)

Set ds = Map1.Datasets.Add(miDataSetLayer, lyr)

Set ftrs = lyr.Search("名称 like " + Chr(34) + "%" + List2.Text + "%" + Chr(34))
 'Set ftrs = lyr.Search("名称 like" & "%Text1.Text %")
If ftrs.Count > 0 Then
  Set ftr = ftrs(1)
    Timer1.Enabled = True
   'lyr.Selection.Replace ftr
   'ss = lyr.Selection.Item(1).Style.SymbolFontShadow
   'ss = True

  Map1.ZoomTo (Map1.Zoom) * 0.2, ftr.CenterX, ftr.CenterY
  
  Map1.Refresh
  bb = MsgBox("是否继续查询该地区?", vbOKCancel, "提示")
If bb = vbOK Then
河北.Show
Unload Me
ElseIf bb = vbCancel Then Exit Sub
End If
  End If
End If

End Sub

Private Sub Command2_Click()
Map1.Bounds = Map1.Layers.Bounds

TreeView2.Nodes.Clear
Map1.Layers.RemoveAll
 
Map1.Layers.AddGeoSetLayers ("中国")
''Map1.Bounds = Map1.Layers.Bounds
'
Dim newLayer As Layer
    Set newLayer = Map1.Layers.CreateLayer("Temporary Layer", , 1)
    newLayer.Editable = True
    Set Map1.Layers.InsertionLayer = newLayer

    'UpdateToolbarButtons
End Sub

Private Sub Form_Load()
Set p = LoadPicture("D:\何二佳毕业设计\图片\Blue hills.jpg") '写上你自己的图片"
Picture = p
Screen.MousePointer = 99 '用户鼠标类型
Screen.MouseIcon = LoadPicture("D:\何二佳毕业设计\图片\ico\VIEWER1.ico") '读取鼠标的图标文件
Dim R As Integer
Dim mymenu
mymenu = GetSystemMenu(Me.hwnd, 0)
RemoveMenu mymenu, &HF060, R
Dim ss As String
List1.Clear
ss = App.Path & "\Maps\中国.gst"
Map1.Geoset = ss
 List1.AddItem "名称"
 'List1.AddItem "人口（人）"
' List1.AddItem "面积（平方公里）"
 ' List1.AddItem "所在区位"
 'List1.AddItem "省会"
 Set m_Layer = Map2.Layers.CreateLayer("Rectlayer")     '在Map2创建图层

'Call ResizeInit(Me)     '在程序装入时必须加入

 Dim nodX     As Node '改变treeview2背景
  Set nodX = TreeView2.Nodes.Add(, , "R", "Root") '改变treeview2背景
  Set nodX = TreeView2.Nodes.Add("R", tvwChild, "C1", "Child   1") '改变treeview2背景
  Set nodX = TreeView2.Nodes.Add("R", tvwChild, "C2", "Child   2") '改变treeview2背景
  Set nodX = TreeView2.Nodes.Add("R", tvwChild, "C3", "Child   3") '改变treeview2背景
  Set nodX = TreeView2.Nodes.Add("R", tvwChild, "C4", "Child   4") '改变treeview2背景
  nodX.EnsureVisible '改变treeview2背景
  TreeView2.Style = tvwTreelinesText       '   Style   4.'改变treeview2背景
  TreeView2.BorderStyle = vbFixedSingle '改变treeview2背景
Dim lngStyle     As Long '改变treeview2背景
  Call SendMessage(TreeView2.hwnd, TVM_SETBKCOLOR, 0, ByVal RGB(0, 120, 130))         '改变treeview2背景
  '改变背景到红色
    
  lngStyle = GetWindowLong(TreeView2.hwnd, GWL_STYLE) '改变treeview2背景
  Call SetWindowLong(TreeView2.hwnd, GWL_STYLE, lngStyle - TVS_HASLINES) '改变treeview2背景
  Call SetWindowLong(TreeView2.hwnd, GWL_STYLE, lngStyle) '改变treeview2背景

End Sub

Private Sub Form_Resize()
Set Picture = Nothing
PaintPicture p, 0, 0, Width, Height
Debug.Print Width
Map1.Move Map1.Left, Map1.Top, ScaleWidth - Map1.Left, ScaleHeight - Map1.Top

 ' Call ResizeForm(Me)     '确保窗体改变时控件随之改变

 '当窗体大小改变时，改变Map1和TreeView1控件的大小，
  '使这两个控件始终添满整个窗体
  Map1.Move Map1.Left, Map1.Top, ScaleWidth - Map1.Left, ScaleHeight - Map1.Top
  
  Map1.Move Map1.Left, Map1.Top, ScaleWidth - Map1.Left, ScaleHeight - Map1.Top    '添加标注
  TreeView2.Nodes.Clear
  
End Sub '

Private Sub Label1_Click()
土地等级划分.Show
End Sub

Private Sub List1_Click()
Dim objfeature As New Feature
List2.Clear
For Each objfeature In Map1.Layers(List1.Text).AllFeatures
List2.AddItem objfeature.KeyValue
Next
Set objfeature = Nothing
End Sub

Private Sub menuback_Click()
Unload Me
Frmlogin.Show

End Sub

Private Sub menuhebei_Click()
Unload Me
河北.Show
End Sub

Private Sub Timer1_Timer()
Static flag As Integer

 If flag < 80 Then
 If kk = False Then
' lyr.Selection.Replace ftr
 kk = True
 Else
 'lyr.Selection.ClearSelection
 kk = False
 End If
 flag = flag + 1
 Else
 Timer1.Enabled = False
 flag = 1
 End If
End Sub



Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)


Select Case Button.Index
 
 
    Case 1
          Map1.CurrentTool = miZoomInTool
    Case 2
          Map1.CurrentTool = miZoomOutTool
    Case 3
        Map1.CurrentTool = miPanTool
    Case 4
        Map1.CurrentTool = miArrowTool
    Case 5
        Map1.CurrentTool = miRectSelectTool
    Case 6
        Map1.CurrentTool = miPolygonSelectTool
    Case 7
        Map1.CurrentTool = miRectSelectTool
    Case 8
        Map1.CurrentTool = miSelectTool
    Case 9
        Map1.CurrentTool = miCenterTool
    Case 10
        Map1.Bounds = Map1.Layers.Bounds
    
End Select

End Sub
Private Sub Map1_MapViewChanged()

Dim tempFea As MapXLib.Feature      '声明Feature变量
Dim tempPnts As MapXLib.Points     '声明Points变量
Dim tempStyle As MapXLib.Style       '声明Style变量

'矩形边框还没有创建时
If m_Layer.AllFeatures.Count = 0 Then
'设置矩形边框样式
Set tempStyle = New MapXLib.Style         '创建Style对象
tempStyle.RegionPattern = miPatternNoFill    '设置Style的矩形内部填充样式
tempStyle.RegionBorderColor = 255         '设置Style的矩形边框颜色
tempStyle.RegionBorderWidth = 2           '设置Style的矩形边框宽度

'在图层创建大小为Map1的边界的Rectangle对象
Set tempFea = Map2.FeatureFactory.CreateRegion(Map1.Bounds, tempStyle)
Set m_Fea = m_Layer.AddFeature(tempFea)    '添加矩形边框
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

End Sub

Private Sub Map1_SelectionChanged()
'当选择集发生改变时，将出发该事件
  Dim l As Layer
  Dim f As Feature
  Dim parNode As Node
  TreeView2.Nodes.Clear
  '通过循环加入每个图层中选择集对象中的特征对象的名称
  For Each l In Map1.Layers
    If l.Selection.Count > 0 Then
      '加入图层名称
      Set parNode = TreeView2.Nodes.Add(, , l.Name, l.Name)
      parNode.Expanded = True
      For Each f In l.Selection
        '加入特征对象的名称
        TreeView2.Nodes.Add parNode, tvwChild, parNode.Key & _
                            f.Name, f.Name
      Next
    End If
  Next
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