frmmain.frm

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

    Dim iLength As Integer      '字符串长度
    Dim i As Integer
    Dim strTemp As String
    Dim strTemp1 As String
    Dim iPosition As Integer
    Dim bTag As Boolean
    
    '去扩展名
    iPosition = InStrRev(strPath, ".")
    If iPosition <> 0 Then
        strTemp = Left$(strPath, iPosition - 1)
    Else
        strTemp = strPath
    End If
    
    '去路径名
    iLength = Len(strTemp)
    iPosition = InStrRev(strPath, "\")
    If iPosition <> 0 Then
        strTemp = Mid$(strTemp, iPosition + 1)
    End If
    
    PathToName = strTemp
End Function

Private Sub btnClose_Click()
    Unload frmMain
End Sub

Private Sub btnCreateObj_Click()
    '创建对象按钮。先判断地图窗口中是否有打开的图层
    If Me.SuperMap1.Layers.Count = 0 Then
        MsgBox "地图窗口中没有打开的图层，不能编辑！", vbInformation
        Exit Sub
    End If
    
    '弹出菜单
    PopupMenu mnuCreateObjPopuMenu, , btnCreateObj.Left, btnCreateObj.Top + btnCreateObj.Height
End Sub

Private Sub btnDelectObj_Click() '删除所选择的对象
    Dim objRecordset As soRecordset
    
    '判断有无选中的对象
    If Me.SuperMap1.selection.Count = 0 Then
        MsgBox "请先选中要删除的对象!", vbInformation
    Else
        If MsgBox("此操作无法恢复！确认吗？", vbExclamation + vbYesNo, "警告") = vbNo Then Exit Sub
        
        '转化为记录集
        Set objRecordset = Me.SuperMap1.selection.ToRecordset(False)
        If objRecordset Is Nothing Then
            MsgBox "未能得到被选择的对象", vbInformation
        Else
            Me.SuperMap1.selection.RemoveAll
            
            '循环删除对象
            With objRecordset
                .MoveFirst
                Do Until .IsEOF
                    .Edit
                    .Delete
                    .Update
                    
                    .MoveNext
                Loop
            End With
            
            Me.SuperMap1.Layers(1).Dataset.ComputeBounds '重新计算数据集范围
            Me.SuperMap1.Refresh '刷新地图
        End If
    End If
End Sub

Private Sub btnAction_Click(Index As Integer)
    '地图基本操作
    Select Case Index
        Case 0            '放大
            Me.SuperMap1.Action = scaZoomIn
        Case 1            '缩小
            Me.SuperMap1.Action = scaZoomOut
        Case 2            '平移
            Me.SuperMap1.Action = scaPan
        Case 3            '全幅显示
            Me.SuperMap1.ViewEntire
        Case 4            '选择
            Me.SuperMap1.Action = scaSelect
        Case 5            '自由缩放
            Me.SuperMap1.Action = scaZoomFree
    End Select
End Sub

Private Sub Form_Load()
    Dim objDataSource As soDataSource
    Dim i As Integer
    Dim strDataSourceName As String                 '数据源全名
    Dim strDataSourceAlias As String               '数据源别名
    
    '连接SuperMap与SuperWorkspace控件
    SuperMap1.Connect SuperWorkspace1.Handle
    
    '打开数据源
    strDataSourceName = App.Path & "\..\Data\CreateObjAsCADDt\data.sdb"
    strDataSourceAlias = PathToName(strDataSourceName)
    Set objDataSource = SuperWorkspace1.OpenDataSource(strDataSourceName, strDataSourceAlias, sceSDBPlus, False)
    If objDataSource Is Nothing Then
        MsgBox "打开数据源错误!", vbCritical
    Else
        '打开数据源中的CAD数据集(没有则不打开)
        If objDataSource.Datasets.Count >= 1 Then
            Dim fName As String
            
            For i = 1 To objDataSource.Datasets.Count
                fName = objDataSource.Datasets(i).Name
                objDataSource.DeleteDataset fName
            Next
        End If
        
        Dim objDt As soDataset
        Set objDt = objDataSource.CreateDataset("CADDataset", scdCAD, scoDefault)
        If objDt Is Nothing Then
            MsgBox "创建复合数据集失败 ！", vbInformation, "消息："
            Exit Sub
        Else
            Me.SuperMap1.Layers.AddDataset objDataSource.Datasets(1), True
            Me.SuperMap1.ViewEntire
        End If
    End If
End Sub

Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Then Exit Sub
    
    SuperMap1.Left = 5
    SuperMap1.Width = Me.ScaleWidth - 2 * SuperMap1.Left
    SuperMap1.Height = Me.ScaleHeight - SuperMap1.Top
    Line1(0).X2 = Me.ScaleWidth
    Line1(1).X2 = Line1(0).X2
End Sub

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

Private Sub mnuCreateObj_Click(Index As Integer)
    '创建各种对象，对文本和非文本对象用bCreateText变量来标识
    With Me.SuperMap1
        Select Case Index
            Case 0                        '点
                bCreateText = False
                .Action = scaTrackPoint
            Case 1                        '折线
                bCreateText = False
                .Action = scaTrackPolyline
            Case 2                        '曲线
                bCreateText = False
                .Action = scaTrackCurve
            Case 3                        '矩形
                bCreateText = False
                .Action = scaTrackRectangle
            Case 4                        '椭圆
                bCreateText = False
                .Action = scaTrackEllipse
            Case 5                        '圆
                bCreateText = False
                .Action = scaTrackCircle
            Case 6                        '多边形
                bCreateText = False
                .Action = scaTrackPolygon
            Case 7                        '文本
                bCreateText = True
                .Action = scaTrackPoint
        End Select
    End With
End Sub

Private Sub SuperMap1_Tracked()
    Dim objDtVector As soDatasetVector
    Dim objRecordset As soRecordset
    Dim objGeometry As soGeometry
    Dim nIndex As Long
    
    If Me.SuperMap1.Layers.Count = 0 Then Exit Sub
    
    '取数据集
    Set objDtVector = Me.SuperMap1.Layers(1).Dataset
    If objDtVector Is Nothing Then
        MsgBox "未能获得当前编辑的数据集", vbInformation
        Exit Sub
    Else
        '获得记录集
        Set objRecordset = objDtVector.Query("", True)
    End If
    
    If objRecordset Is Nothing Then
        MsgBox "未能得到记录集", vbInformation
        Set objDtVector = Nothing
        Exit Sub
    End If
    
    '区分创建文本对象和非文本对象，调用不同的代码
    If bCreateText = True Then                              '创建文本对象
        Call CreateText(objRecordset)
        objRecordset.Update
        SuperMap1.Refresh
    Else                           '创建非文本对象
        '获得要创建的对象
        Set objGeometry = Me.SuperMap1.TrackedGeometry
        If objGeometry Is Nothing Then
            MsgBox "未能得到绘制的对象", vbInformation
            Set objRecordset = Nothing
            Set objDtVector = Nothing
            Exit Sub
        Else
            '添加要创建的对象。如果返回值=-1，说明失败。其余的返回值是对象的SmID值
            nIndex = objRecordset.AddNew(objGeometry)
            If nIndex < 0 Then                    '创建失败
                MsgBox "添加对象失败", vbInformation
            Else                                  '创建成功
                objRecordset.Update
                SuperMap1.Refresh
            End If
        End If
    End If
End Sub