frmaddtext.frm

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

VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.1#0"; "SuperMap.ocx"
Begin VB.Form frmAddText 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "AddText"
   ClientHeight    =   6450
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8685
   Icon            =   "frmAddText.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6450
   ScaleWidth      =   8685
   StartUpPosition =   2  'CenterScreen
   Begin SuperMapLib.SuperMap SuperMap1 
      Height          =   5895
      Left            =   0
      TabIndex        =   11
      Top             =   540
      Width           =   8655
      _Version        =   327681
      _ExtentX        =   15266
      _ExtentY        =   10398
      _StockProps     =   160
   End
   Begin SuperMapLib.SuperWorkspace SuperWorkspace1 
      Left            =   2820
      Top             =   3060
      _Version        =   327681
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.Frame Frame3 
      Height          =   555
      Left            =   30
      TabIndex        =   0
      Top             =   -75
      Width           =   8610
      Begin VB.CommandButton btnZoomFree 
         Caption         =   "自由缩放"
         Height          =   360
         Left            =   2610
         TabIndex        =   10
         Top             =   150
         Width           =   885
      End
      Begin VB.CheckBox chkTransparent 
         Caption         =   "背景透明"
         Height          =   195
         Left            =   7410
         TabIndex        =   9
         Top             =   330
         Value           =   1  'Checked
         Width           =   1185
      End
      Begin VB.CheckBox chkFixSize 
         Caption         =   "固定大小"
         Height          =   210
         Left            =   7410
         TabIndex        =   8
         Top             =   120
         Width           =   1185
      End
      Begin VB.CommandButton btnStartTrcak 
         Caption         =   "点击这里测试"
         Height          =   360
         Left            =   6075
         TabIndex        =   7
         Top             =   150
         Width           =   1320
      End
      Begin VB.CommandButton btnRefresh 
         Caption         =   "刷新"
         Height          =   360
         Left            =   4335
         TabIndex        =   6
         Top             =   150
         Width           =   840
      End
      Begin VB.CommandButton btnviewEntire 
         Caption         =   "全幅"
         Height          =   360
         Left            =   5175
         TabIndex        =   5
         Top             =   150
         Width           =   855
      End
      Begin VB.CommandButton btnSelect 
         Caption         =   "选择"
         Height          =   360
         Left            =   60
         TabIndex        =   4
         Top             =   150
         Width           =   840
      End
      Begin VB.CommandButton btnPan 
         Caption         =   "漫游"
         Height          =   360
         Left            =   3495
         TabIndex        =   3
         Top             =   150
         Width           =   840
      End
      Begin VB.CommandButton btnZoomOut 
         Caption         =   "缩小"
         Height          =   360
         Left            =   1755
         TabIndex        =   2
         Top             =   150
         Width           =   855
      End
      Begin VB.CommandButton btnZoomIn 
         Caption         =   "放大"
         Height          =   360
         Left            =   900
         TabIndex        =   1
         Top             =   150
         Width           =   855
      End
   End
End
Attribute VB_Name = "frmAddText"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范在SuperMap 的鼠标点击处加入一个文本到TrackingLayer上
'所用控件：SuperMap 控件、SuperWorkspace 控件
'所用数据：当前目录..\Data\world\world.sdb和world.sdd文件
'操作说明：
'         点击"这里测试"按钮，再在地图窗口中点击，就可以在点击处显示一个文本
'         "背景透明"和"固定大小"使文本以不同风格显示
'===================================SuperMap Objects示范工程说明结束=====================================

Option Explicit
 
Private Sub btnZoomFree_Click()                    '自由缩放
    SuperMap1.Action = scaZoomFree
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SuperMap1.Close
    SuperMap1.Disconnect
    SuperWorkspace1.Close
End Sub

Private Sub SuperMap1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    '在鼠标点击处加入一个文本到TrackingLayer上
    '其中：文本的内容和大小在程序中写定，也可以修改。详见以下代码
    If SuperMap1.Action = 100000 Then
        Dim objGeoPoint As New soGeoPoint           '声明几何点对象变量
        Dim objStyle As New soStyle                 '声明文本定位点风格变量
        Dim objMapBounds As soRect
        
        SuperMap1.TrackingLayer.ClearEvents         '清除soTrackingLayer上的所有对象
        
        objStyle.PenColor = 255                     '颜色
        objStyle.SymbolSize = 50                    '大小,以像素为单位
        objStyle.SymbolStyle = 1                    '符号为符号库中id=1的符号
        objGeoPoint.x = SuperMap1.PixelToMapX(ScaleX(x, vbTwips, vbPixels))
        objGeoPoint.y = SuperMap1.PixelToMapY(ScaleY(y, vbTwips, vbPixels))
        SuperMap1.TrackingLayer.AddEvent objGeoPoint, objStyle, ""
        
        Dim objGeoText As New soGeoText             '文本对象
        Dim objTextPart As New soTextPart           '文本内容子对象
        
        objTextPart.Text = "北京超图"               '设置文本的内容,可以修改
       
        '下面两行代码中的值一定要设置准确，否则定位会不准确。
        objTextPart.x = objGeoPoint.x
        objTextPart.y = objGeoPoint.y
        
        objTextPart.Rotation = 0                    '设置文本的旋转角度
        objGeoText.AddPart objTextPart              '把文本子对象加入到文本对象中
        
        Set objMapBounds = SuperMap1.ViewBounds
        
        Dim objGeoTextStyle As New soTextStyle      '文本风格对象
        With objGeoTextStyle
            .Color = vbBlue                         '文本颜色
            .Align = sctBottomCenter                '文本的对齐方式（底部中间对齐）
        End With
        
        '文字高度使用的是地理坐标，请根据不同的图设置合适的值（最好在地图上量算一下）
        '两种情况下所使用的单位不同
        If (chkFixSize.Value = vbChecked) Then      '使用逻辑单位
            objGeoTextStyle.FixedSize = True
            objGeoTextStyle.FixedTextSize = 50
        Else
            objGeoTextStyle.FixedSize = False
            objGeoTextStyle.FontHeight = objMapBounds.Height / 27    '使用地理坐标
        End If
        
        If chkTransparent.Value = vbChecked Then
            objGeoTextStyle.Transparent = True      '背景是否透明，True表示透明
        Else
            objGeoTextStyle.Transparent = False
            objGeoTextStyle.BgColor = vbWhite
        End If
        
        Set objGeoText.TextStyle = objGeoTextStyle  '设置文本的风格
        
        SuperMap1.TrackingLayer.AddEvent objGeoText, Nothing, ""  '跟踪层上添加文本
        SuperMap1.TrackingLayer.Refresh
    End If
    
    Set objGeoPoint = Nothing
    Set objGeoText = Nothing
    Set objStyle = Nothing
    Set objTextPart = Nothing
    Set objGeoTextStyle = Nothing
End Sub

Public Function PathToName(ByVal strPath As String) As String
    '=====================================================
    '自定义函数,将文件全路径名转化为文件名(无路径名,无扩展名)
    '=====================================================
    Dim iLength As Integer      '字符串长度
    Dim i As Integer
    Dim strTemp As String
    Dim strTemp1 As String
    Dim iPosition As Integer
    
    iPosition = 999
    If InStr(strPath, ".") <> 0 Then
        strTemp = Left(strPath, Len(strPath) - 4)
    Else
        strTemp = strPath
    End If
      
    iLength = Len(strTemp)
    For i = Len(strPath) To 1 Step -1
        If Mid$(strTemp, i, 1) = "\" Then
            iPosition = i
            Exit For
        End If
    Next
    If iPosition = 999 Then
        PathToName = strTemp
    Else
        PathToName = Right(strTemp, iLength - iPosition)
    End If
End Function

Private Sub btnPan_Click()        '漫游
    SuperMap1.Action = scaPan
End Sub

Private Sub btnRefresh_Click()    '刷新
    SuperMap1.Refresh
End Sub

Private Sub btnSelect_Click()     '选择
    SuperMap1.Action = scaSelect
End Sub

Private Sub btnviewEntire_Click() '全幅显示
    SuperMap1.ViewEntire
End Sub

Private Sub btnZoomIn_Click()     '放大
    SuperMap1.Action = scaZoomIn
End Sub

Private Sub btnZoomOut_Click()    '缩小
    SuperMap1.Action = scaZoomOut
End Sub

Private Sub btnStartTrcak_Click() '“这里测试”
    SuperMap1.Action = 100000 '说明：100000的Action值不是系统定义的，没有默认的操作。
End Sub

Private Sub Form_Load()
    SuperMap1.Connect SuperWorkspace1.Object
    
    Dim objDS As soDataSource
    Dim strDsName As String
    Dim strDsAlias As String
    
    strDsName = App.Path & "\..\data\world\world.sdb"
    strDsAlias = PathToName(strDsName)
    Set objDS = Me.SuperWorkspace1.OpenDataSource(strDsName, strDsAlias, sceSDBPlus, True)
    If objDS Is Nothing Then
        MsgBox "数据源打开失败！", vbInformation
    Else
        SuperMap1.Layers.AddDataset objDS.Datasets("Grid"), True
        SuperMap1.Layers.AddDataset objDS.Datasets("world"), False
    End If
    
    SuperMap1.Action = scaSelect
    SuperMap1.MarginPanEnable = False
End Sub

Private Sub Form_Resize()
On Error Resume Next
     SuperMap1.Width = Me.Width
     SuperMap1.Height = Me.Height - 850
End Sub