frmmain.frm

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

VERSION 5.00
Object = "{02BEE3A6-4264-45B0-93C8-76FBBA329150}#5.2#0"; "SuperLegend.ocx"
Object = "{A61255F7-0A20-431C-86CE-78C14314BE9E}#5.2#0"; "SuperWkspManager.ocx"
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "动态分段主窗体"
   ClientHeight    =   6705
   ClientLeft      =   150
   ClientTop       =   435
   ClientWidth     =   10695
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6705
   ScaleWidth      =   10695
   StartUpPosition =   2  'CenterScreen
   Begin SuperLegendLib.SuperLegend SuperLegend1 
      Height          =   2895
      Left            =   120
      TabIndex        =   1
      Top             =   3720
      Width           =   2055
      _Version        =   327682
      _ExtentX        =   3625
      _ExtentY        =   5106
      _StockProps     =   132
      Appearance      =   1
   End
   Begin SuperMapLib.SuperMap SuperMap1 
      Height          =   6135
      Left            =   2280
      TabIndex        =   0
      Top             =   480
      Width           =   8415
      _Version        =   327682
      _ExtentX        =   14843
      _ExtentY        =   10821
      _StockProps     =   160
      BorderStyle     =   1
   End
   Begin VB.CommandButton btnSetEvent 
      Caption         =   "设置事件表"
      Height          =   375
      Left            =   7185
      TabIndex        =   9
      Top             =   15
      Width           =   1260
   End
   Begin SuperMapLib.SuperWorkspace SuperWorkspace1 
      Left            =   3345
      Top             =   3285
      _Version        =   327682
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin MSComDlg.CommonDialog cmdOpen 
      Left            =   4365
      Top             =   4380
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton btnViewEntire 
      Caption         =   "全幅"
      Height          =   375
      Left            =   6090
      TabIndex        =   8
      Top             =   15
      Width           =   990
   End
   Begin VB.CommandButton btnPan 
      Caption         =   "平移"
      Height          =   375
      Left            =   5010
      TabIndex        =   7
      Top             =   15
      Width           =   990
   End
   Begin VB.CommandButton btnZoomout 
      Caption         =   "缩小"
      Height          =   375
      Left            =   3945
      TabIndex        =   6
      Top             =   15
      Width           =   990
   End
   Begin VB.CommandButton btnZoomin 
      Caption         =   "放大"
      Height          =   375
      Left            =   2895
      TabIndex        =   5
      Top             =   15
      Width           =   990
   End
   Begin VB.CommandButton btnSelect 
      Caption         =   "选择"
      Height          =   375
      Left            =   1830
      TabIndex        =   4
      Top             =   15
      Width           =   990
   End
   Begin VB.CommandButton Command1 
      Caption         =   "打开数据源"
      Height          =   375
      Left            =   180
      TabIndex        =   3
      Top             =   15
      Width           =   1575
   End
   Begin SuperWkspManagerLib.SuperWkspManager SuperWkspManager1 
      Height          =   3255
      Left            =   120
      TabIndex        =   2
      Top             =   480
      Width           =   2055
      _Version        =   327682
      _ExtentX        =   3625
      _ExtentY        =   5741
      _StockProps     =   0
      DataTab         =   1
      MapTab          =   1
      LayoutTab       =   1
      SenceTab        =   1
      ResourceTab     =   1
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=========================SuperMap Objects 示范程序说明============================
'1、程序说明：示范如何使用动态分段功能；
'2、使用数据说明：..\Data\DynamicEvent\test.sdb；
'3、操作说明：
'   (1)打开数据源；
'   (2)在数据集列表中选择New_Table，点击“设置事件表”，在弹出的对话框中设置相关选项，
'      其中属性关联字段设置为ID，事件类型设置为pointevent，Measure字段设置为length，
'      Route关联字段设置为smid，然后确定。可以在地图窗口中将Route数据集和NewTable数
'      据集叠加显示看看效果；
'   (3)在数据集列表中选择New_LineTable，点击“设置事件表”，在弹出的对话框中设置相关
'      选项，其中属性关联字段设置为ID，事件类型设置为lineevent，起点Measure设置为FLength，
'      终点Measure设置为TLength，Route关联字段设置为smid，然后确定。可以在地图窗口中
'      将Route数据集和New_LineTable数据集叠加显示看看效果。
'==================================================================================

Option Explicit

Public strSelectName As String
Public strSelectParentName As String
Public lSelectFlag As Long

Private Sub btnPan_Click()
    SuperMap1.Action = scaPan
End Sub

Private Sub btnSelect_Click()
    SuperMap1.Action = scaSelect
End Sub

Private Sub btnSetEvent_Click()
    Dim objds As soDataSource
    Dim objdt As soDataset
    
    Set objds = SuperWorkspace1.Datasources.Item(strSelectParentName)
    If objds Is Nothing Then Exit Sub
    Set objdt = objds.Datasets.Item(strSelectName)
    If objdt Is Nothing Then Exit Sub
    
    If objdt.Type = scdTabular Then
        frmEventSetting.Show vbModal, Me
    Else
        MsgBox "该项功能是针对属性数据表数据集的", vbInformation, "提示信息"
    End If
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 Command1_Click()
    Dim strname As String
    Dim objds As soDataSource
    
    With cmdOpen
        .CancelError = False
        .DialogTitle = "打开数据源"
        .Filter = "(*.sdb)|*.sdb"
        .ShowOpen
        strname = .FileName
    End With
    If strname <> "" Then
        Set objds = SuperWorkspace1.OpenDataSource(strname, PathToName(strname), sceSDBPlus, False)
        If objds Is Nothing Then
            MsgBox "打开数据源失败"
        Else
            SuperWkspManager1.Refresh
        End If
    End If
End Sub

Private Sub Form_Load()
    SuperMap1.Connect SuperWorkspace1.Handle
    SuperLegend1.Connect SuperMap1.Handle
    SuperWkspManager1.Connect SuperWorkspace1.Handle
End Sub

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

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

Private Sub SuperLegend1_Modified()
    SuperMap1.Refresh
End Sub

Private Sub SuperWkspManager1_LClick(ByVal nFlag As SuperMapLib.seSelectedItemFlag, ByVal strSelected As String, ByVal strParent As String)
    lSelectFlag = nFlag
    strSelectName = strSelected
    strSelectParentName = strParent
End Sub

Private Sub SuperWkspManager1_LDbClick(ByVal nFlag As SuperMapLib.seSelectedItemFlag, ByVal strSelected As String, ByVal strParent As String)
    Dim objds As soDataSource
    Dim objdt As soDataset
    Dim objLayer As soLayer
    
    If nFlag = scsDataset Then
        Set objds = SuperWorkspace1.Datasources(strParent)
        If objds Is Nothing Then Exit Sub
        Set objdt = objds.Datasets(strSelected)
        If objdt Is Nothing Then Exit Sub
        
        Set objLayer = SuperMap1.Layers.AddDataset(objdt, True)
        If Not objLayer Is Nothing Then
            If objdt.Type = scdTabular Then
                Dim objThemeUnique As soThemeUnique
                
                Set objThemeUnique = objLayer.ThemeUnique
                With objThemeUnique
                    .Field = "smid"
                    .MakeDefault
                    
                    .Enable = True
                End With
            End If
        End If
        
        SuperMap1.Refresh
        SuperLegend1.Refresh
    End If
End Sub