frmmain.frm

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

VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frmMain 
   Caption         =   "地图窗口"
   ClientHeight    =   5505
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8610
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   5505
   ScaleWidth      =   8610
   StartUpPosition =   2  'CenterScreen
   Begin SuperMapLib.SuperWorkspace SuperWorkspace1 
      Left            =   7680
      Top             =   3720
      _Version        =   327682
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin SuperMapLib.SuperMap SuperMap1 
      Height          =   3195
      Left            =   60
      TabIndex        =   9
      Top             =   540
      Width           =   4035
      _Version        =   327682
      _ExtentX        =   7117
      _ExtentY        =   5636
      _StockProps     =   160
   End
   Begin VB.CommandButton btnAction 
      Caption         =   "选择"
      Height          =   360
      Index           =   4
      Left            =   45
      TabIndex        =   7
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnClose 
      Caption         =   "关闭"
      Height          =   360
      Left            =   7665
      TabIndex        =   6
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnDelectObj 
      Caption         =   "删除对象"
      Height          =   360
      Left            =   6690
      TabIndex        =   5
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnAction 
      Caption         =   "平移"
      Height          =   360
      Index           =   2
      Left            =   3825
      TabIndex        =   4
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnAction 
      Caption         =   "缩小"
      Height          =   360
      Index           =   1
      Left            =   1935
      TabIndex        =   3
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnAction 
      Caption         =   "放大"
      Height          =   360
      Index           =   0
      Left            =   990
      TabIndex        =   2
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnAction 
      Caption         =   "全幅显示"
      Height          =   360
      Index           =   3
      Left            =   4770
      TabIndex        =   1
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnCreateObj 
      Caption         =   "创建对象"
      Height          =   360
      Left            =   5745
      TabIndex        =   0
      Top             =   30
      Width           =   945
   End
   Begin VB.CommandButton btnAction 
      Caption         =   "自由缩放"
      Height          =   360
      Index           =   5
      Left            =   2880
      TabIndex        =   8
      Top             =   30
      Width           =   945
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000005&
      Index           =   1
      X1              =   0
      X2              =   10485
      Y1              =   420
      Y2              =   420
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000003&
      Index           =   0
      X1              =   0
      X2              =   10485
      Y1              =   405
      Y2              =   405
   End
   Begin VB.Menu mnuCreateObjPopuMenu 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建点"
         Index           =   0
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建折线"
         Index           =   1
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建曲线"
         Index           =   2
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建矩形"
         Index           =   3
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建椭圆"
         Index           =   4
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建圆"
         Index           =   5
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建多边形"
         Index           =   6
      End
      Begin VB.Menu mnuCreateObj 
         Caption         =   "创建文本"
         Index           =   7
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范如何自定义编辑复合数据集
'所用控件：SuperMap控件、SuperWorkspace控件
'所用数据：..\Data\CreateObjAsCADDt\data.sdb
'操作说明：
'        1、在程序启动的时候打开数据源并删除所有数据集，重新创建一个新的CAD数据集，加载新数据集到SuperMap上，
'           并把该数据集设置为可编辑；
'        2、单击"创建对象"按钮，弹出创建对象菜单，选择相应的菜单进行对象的创建；
'        3、选择一个或多个对象，单击"删除对象"按钮来删除对象。
'
'===================================SuperMap Objects示范工程说明结束=====================================
Option Explicit

Dim bCreateText As Boolean    '创建文本对象和非文本对象的标志变量。创建文本对象时该值为True

Private Sub CreateText(ByRef objRecordset As soRecordset)
'==================================================================
'  创建文本模块。参数objRecordset是文本要加入的数据集所对应的记录集
'==================================================================
    Dim objGeoText As New soGeoText       '文本对象变量
    Dim objGeometry As soGeometry         '几何对象变量，存放在SuperMap中Track所得到的对象
    Dim objGeoPoint As soGeoPoint         '当soGeometry的类型是点时，存放到此变量中。作为文本对象的定位点
    Dim objTextPart As New soTextPart     '文本子对象变量，要加入的文本内容存放在此对象变量的Text属性中
    Dim objTextStyle As New soTextStyle
                
    '取出文本对象的定位点
    Set objGeometry = Me.SuperMap1.TrackedGeometry
    If objGeometry.Type = scgPoint Then
        Set objGeoPoint = objGeometry
    End If
    
    objTextPart.x = objGeoPoint.x
    objTextPart.y = objGeoPoint.y
    
    '设置要添加的文本内容，可以弹出一个对话框来获取，此处用代码给定。
    objTextPart.Text = "SuperMap China"
    objGeoText.AddPart objTextPart
    
    objTextStyle.FontName = "Arial"
    objTextStyle.FixedSize = True
    objTextStyle.FixedTextSize = 40
    Set objGeoText.TextStyle = objTextStyle
    
    '把文本对象加入到数据集的记录集中
    objRecordset.AddNew objGeoText
    objRecordset.Update
    
    SuperMap1.Refresh
    
    Set objTextPart = Nothing
    Set objGeoText = Nothing
    Set objTextStyle = Nothing
End Sub

Private Function PathToName(ByVal strPath As String) As String
'=====================================================
'  将文件全路径名转化为文件名(无路径名,无扩展名)
'=====================================================