form02.frm

Z值渲染

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Begin VB.Form Form02 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Z值渲染"
   ClientHeight    =   8400
   ClientLeft      =   1875
   ClientTop       =   420
   ClientWidth     =   7860
   FillColor       =   &H00C0C0C0&
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   8400
   ScaleWidth      =   7860
   Begin VB.CommandButton Command2 
      Caption         =   "Z值渲染"
      Height          =   375
      Left            =   6480
      TabIndex        =   5
      Top             =   7800
      Width           =   1095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "恢复"
      Height          =   375
      Left            =   6480
      TabIndex        =   1
      Top             =   7200
      Width           =   1095
   End
   Begin MapObjects2.Map Map1 
      Height          =   6855
      Left            =   360
      TabIndex        =   0
      Top             =   0
      Width           =   7095
      _Version        =   131072
      _ExtentX        =   12515
      _ExtentY        =   12091
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      ScrollBars      =   0   'False
      Contents        =   "Form02.frx":0000
   End
   Begin VB.Label clue 
      Caption         =   "Label1"
      Height          =   975
      Left            =   3600
      TabIndex        =   4
      Top             =   7080
      Width           =   2535
   End
   Begin VB.Label values 
      Caption         =   "Label1"
      Height          =   1335
      Left            =   1200
      TabIndex        =   2
      Top             =   6960
      Width           =   2175
   End
   Begin VB.Label Columns 
      Caption         =   "Label2"
      Height          =   1335
      Left            =   120
      TabIndex        =   3
      Top             =   6960
      Width           =   1095
   End
End
Attribute VB_Name = "Form02"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Xuewei,2003/6/9；
'Zrenderer的一个简单示例；

Option Explicit
Dim p2 As MapObjects2.Point
Dim f_to_m As Double
Dim m_to_f As Double
Dim theBenEasting As Long
Dim theBenNorthing As Long

Private Sub Command1_Click()
  Map1.Extent = Map1.FullExtent
End Sub

Private Sub Command2_Click()
  Dim Zren As New MapObjects2.ZRenderer
  Dim i As Integer
  Dim Nl
  
  With Zren
    .BreakCount = 6
    .Break(0) = 600
    .Break(1) = 700
    .Break(2) = 800
    .Break(3) = 900
    .Break(4) = 1000
    .Break(5) = 1100
    
    .SymbolType = moPointSymbol
    For i = 0 To .BreakCount
      .Symbol(i).Color = QBColor(i + 8)
      .Symbol(i).Style = moTriangleMarker
      .Symbol(i).Size = i + 4
    Next i
    
    Nl = vbNewLine
    Columns.Caption = "第1级: " & Nl & "第2级: " & Nl & "第3级: " & Nl & "第4级: " & _
    Nl & "第5级: " & Nl & "第6级: " & Nl & "第7级: "
    values.Caption = "深灰,<" & .Break(0) & Nl & "蓝色,<" & .Break(1) & Nl & "绿色,<" & .Break(2) & _
    Nl & "青色,<" & .Break(3) & Nl & "红色,<" & .Break(4) & Nl & "洋红,<" & _
    .Break(5) & Nl & "黄色,>＝" & .Break(5)
  End With
  
  Set Map1.Layers(0).Renderer = Zren
  Map1.Refresh
End Sub

Private Sub Form_Load()
  DrawLayer
  f_to_m = 0.3048037
  m_to_f = 3.2808
  theBenEasting = 216600
  theBenNorthing = 771300
  Load identify
  clue.Caption = "左键画矩形放大，" & vbNewLine & "右键点击山。"
  values.Caption = ""
  Columns.Caption = ""
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
  Dim sym2 As New MapObjects2.Symbol
  sym2.SymbolType = moPointSymbol
  sym2.Color = moRed
  sym2.Style = 2
  sym2.Size = 10
  If Not p2 Is Nothing Then
    Map1.DrawShape p2, sym2
  End If
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then
    Map1.Extent = Map1.TrackRectangle
  Else
    Call Id(X, Y)
  End If
End Sub

Public Sub Id(X As Single, Y As Single)
  Dim p As MapObjects2.Point
  Dim recs As MapObjects2.Recordset
  Dim crecs As MapObjects2.Recordset
  Dim crecsi As Integer
  Dim East_West As String
  Dim North_South As String
  Dim sTol As Double
  Dim theName As String
  Dim pol As MapObjects2.Polygon
  Dim n As Integer, i As Integer
  Dim theType As String
  Dim Nl, t
  
  sTol = 6000
  sTol = sTol * Map1.Extent.Width / Map1.FullExtent.Width
  Set p = Map1.ToMapPoint(X, Y)
  Set pol = p.Buffer(sTol)
  Set recs = Map1.Layers(0).SearchShape(pol, 9, "")
  If (recs.Count > 0) Then
    Set p2 = recs.Fields("Shape").Value
    Map1.FlashShape p2, 3
   
    theType = recs.Fields("Type").ValueAsString
    theName = recs.Fields("Name").ValueAsString
    Nl = vbNewLine
    t = vbTab
    Columns.Caption = "名称: " & Nl & "类别: " & Nl & "东西坐标: " & Nl & "南北坐标: " & Nl & "高度(m): " & Nl & "高度(ft): "
    values.Caption = theName & Nl & theType & Nl & p2.X & Nl & p2.Y & Nl & p2.Z & Nl & p2.Z * m_to_f
   
    East_West = "东"
    North_South = "北"
    If (p2.X) > theBenEasting Then East_West = "西"
    If (p2.Y) > theBenNorthing Then North_South = "南"
    clue.Caption = "正在寻找Ben Nevis山 ..." & vbNewLine & "请向" & theName & "山的" & East_West & North_South & "方向寻找。"
    Map1.TrackingLayer.Refresh True
    
    If theName = "Ben Nevis" Then
      clue.Caption = "找到了!"
      identify.Caption = "Ben Nevis"
      identify.Width = 7140
      identify.Height = 5190
      identify.Visible = True
    Else
      identify.Visible = False
    End If
  Else
     values.Caption = ""
     Columns.Caption = "没有山！"
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  identify.Visible = False
  Unload identify
End Sub

Private Sub DrawLayer()
  Dim dc As New DataConnection
  Dim layer As MapLayer
    
  dc.Database = App.Path + "\..\" + "Scotland"
  If Not dc.Connect Then
    MsgBox "在指定的文件夹下没找到图层数据文件！"
    End
  End If
  
  Set layer = New MapObjects2.MapLayer
  layer.GeoDataset = dc.FindGeoDataset("Scotcoast")
  layer.Symbol.Color = moLightYellow
  Map1.Layers.Add layer
 
  Set layer = New MapObjects2.MapLayer
  layer.GeoDataset = dc.FindGeoDataset("mountains")
  layer.Symbol.Color = moWhite
  layer.Symbol.Size = 6
  layer.Symbol.Style = moTriangleMarker
  Map1.Layers.Add layer
End Sub