frmblink.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.1#0"; "SuperMap.ocx"
Begin VB.Form frmBlink 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "闪烁"
   ClientHeight    =   4575
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7020
   Icon            =   "frmblink.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4575
   ScaleWidth      =   7020
   StartUpPosition =   2  'CenterScreen
   Begin SuperMapLib.SuperMap SuperMap 
      Height          =   4515
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   6975
      _Version        =   327681
      _ExtentX        =   12303
      _ExtentY        =   7964
      _StockProps     =   160
   End
   Begin SuperMapLib.SuperWorkspace SuperWorkspace 
      Left            =   2520
      Top             =   1200
      _Version        =   327681
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   400
      Left            =   4650
      Top             =   3045
   End
End
Attribute VB_Name = "frmBlink"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范SuperMap Objects如何实现闪烁
'所用控件：SuperMap控件和SuperWorkspace控件
'所用数据：\..\Data\world\下的World.sdb和World.sdd两个文件
'操作说明：在地图窗口中选中一个对象，该对象就会闪烁约5秒钟
'
'===================================SuperMap Objects示范工程说明结束=====================================
Option Explicit

Dim objStyle As New soStyle
Dim objGeometry As soGeometry
Dim dOldTimes As Single

Private Sub Form_Load()
    SuperMap.Connect SuperWorkspace.Handle
    
    Dim i As Integer, nDtCount As Integer
    Dim objDS As soDataSource
    Dim objDt As soDataset
    
    Set objDS = SuperWorkspace.OpenDataSource(App.Path & "\..\data\world\World.sdb", "World", sceSDBPlus, True)
    If objDS Is Nothing Then
        MsgBox "打开数据源文件失败！", vbInformation
        Exit Sub
    Else
        nDtCount = objDS.Datasets.Count
        For i = 1 To nDtCount
            Set objDt = objDS.Datasets.Item(i)
            If Not objDt Is Nothing Then
                If objDt.Type = scdLine Or objDt.Type = scdRegion Then
                    SuperMap.Layers.AddDataset objDt, True
                End If
            End If
        Next i
        
        SuperMap.Refresh
        SuperMap.Action = scaSelect
    End If
    
    SuperMap.MarginPanEnable = False
    
    objStyle.BrushColor = vbBlue
    objStyle.PenColor = vbRed
    objStyle.BrushBackTransparent = True
    objStyle.BrushStyle = 2
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set objGeometry = Nothing
    Set objStyle = Nothing
    
    SuperMap.Close
    SuperMap.Disconnect
    SuperWorkspace.Close
End Sub

Private Sub SuperMap_GeometrySelected(ByVal nSelectedGeometryCount As Long)
    Dim objRecordset As soRecordset
    
    Set objRecordset = SuperMap.selection.ToRecordset(True)
    If objRecordset Is Nothing Then
        Exit Sub
    Else
        objRecordset.MoveFirst
        Set objGeometry = objRecordset.GetGeometry
    End If
    
    If objGeometry Is Nothing Then
        Exit Sub
    Else
        SuperMap.selection.RemoveAll
        Timer1.Enabled = True
        dOldTimes = Timer()
    End If
End Sub

Private Sub Timer1_Timer()
    Static bTemp As Boolean
    
    SuperMap.TrackingLayer.ClearEvents
    If Timer() > dOldTimes + 5 Then                        '结束闪烁
        SuperMap.TrackingLayer.Refresh
        SuperMap.Refresh
        Timer1.Enabled = False
        Set objGeometry = Nothing
        dOldTimes = 0#
        Exit Sub
    End If
    
    If bTemp = True Then                                   '闪烁5秒
        SuperMap.TrackingLayer.AddEvent objGeometry, objStyle, ""
    End If
    
    bTemp = Not bTemp
    SuperMap.TrackingLayer.Refresh
End Sub