style.frm

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

      SuperMap1.Connect SuperWorkspace1.Handle
      
      strAlias = "World"                '原则上别名可以任意给,建议取成和数据源文件主名
      nEngineType = sceSDBPlus              'SuperMap支持多种类型，此处为SDB类型
  
      strDataSourceName = App.Path & "\..\Data\world\world.sdb"
      strAlias = "world"
      Set objDS = SuperWorkspace1.OpenDataSource(strDataSourceName, strAlias, nEngineType, False)
            
      If Not (objDS Is Nothing) Then
            '添加数据源文件中的所有数据集到地图窗口中
            Set objDataset = objDS.Datasets.Item("Grid")
            If Not objDataset Is Nothing Then SuperMap1.Layers.AddDataset objDataset, True
            Set objDataset = objDS.Datasets.Item("World")
            If Not objDataset Is Nothing Then SuperMap1.Layers.AddDataset objDataset, True
            Set objDataset = objDS.Datasets.Item("capital")
            If Not objDataset Is Nothing Then SuperMap1.Layers.AddDataset objDataset, True
            Set objDataset = objDS.Datasets.Item("Country_Lable")
            If Not objDataset Is Nothing Then SuperMap1.Layers.AddDataset objDataset, True
      Else
            MsgBox "打开数据源失败！请检查文件" & App.Path & "\..\Data\world.sdb是否存在！", vbInformation
            End
      End If
      SuperMap1.MarginPanEnable = False
      SuperMap1.Action = scaSelect
      
      Set objDS = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
      Set objError = Nothing
      SuperMap1.Close
      SuperMap1.Disconnect
      SuperWorkspace1.Close
End Sub

Private Sub mnuAllText_Click()
      '修改全部注记的风格
      Dim objTextStyle As soTextStyle       '定义文本风格变量
      Dim objDtV As soDatasetVector         '定义目标矢量数据集变量
      Dim objRecordset As soRecordset       '定义目标记录变量
      Dim objGeoText As soGeoText           '定义目标文本对象变量
      
      Set objDtV = SuperMap1.Layers("Country_Lable@world").Dataset          '获取文本图层
      If objDtV Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            SuperMap1.Layers.SetEditableLayer 0
            Exit Sub
      Else
            Set objRecordset = objDtV.Query("", True)
            If objRecordset Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
      End If
      If Not objRecordset.GetGeometry.Type = scgText Then Exit Sub
      Set objGeoText = objRecordset.GetGeometry()
      If objGeoText Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      Else
            Set objTextStyle = objGeoText.TextStyle
            If objTextStyle Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
      End If
      
      If SuperMap1.ShowTextStylePicker(objTextStyle) = True Then
            objRecordset.MoveFirst
            Do Until objRecordset.IsEOF
                  Set objGeoText = objRecordset.GetGeometry()
                  If Not (objGeoText Is Nothing) Then
                        Set objGeoText.TextStyle = objTextStyle
                        objRecordset.Edit
                        objRecordset.SetGeometry objGeoText
                        objRecordset.Update
                  End If
                  Set objGeoText = Nothing
                  objRecordset.MoveNext
            Loop
      End If
      SuperMap1.Refresh
      
      Set objGeoText = Nothing
      Set objTextStyle = Nothing
      Set objRecordset = Nothing
      Set objDtV = Nothing
End Sub

Private Sub mnuCongenerText_Click()
      '设置同类注记风格
      Dim objDtVector As soDatasetVector
      Dim objRecordset As soRecordset
      Dim objDestTextStyle As soTextStyle    '存放用户要改为的目标风格
      Dim objTextStyle As soTextStyle        '每个对象的风格，用于与用户设定的条件比较，符合条件的才修改
      Dim objGeoText  As soGeoText
      Dim i As Long
      Dim strFontName As String, dFontHeight As Double, nColor As Long   '这些变量存放用户所选的文本的特征值
      
      If FrmStyle.SuperMap1.selection.Count = 0 Then
            MsgBox "请至少选择一个注记对象！", vbInformation
            Exit Sub
      Else
            Set objDtVector = FrmStyle.SuperMap1.selection.Dataset
            If objDtVector Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
      End If
            
      Set objRecordset = FrmStyle.SuperMap1.selection.ToRecordset(True)
      If objRecordset Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Set objDtVector = Nothing
            Exit Sub
      End If

      objRecordset.MoveFirst
      If Not objRecordset.GetGeometry.Type = scgText Then Exit Sub
      Set objGeoText = objRecordset.GetGeometry()
      If objGeoText Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      Else
            Set objDestTextStyle = objGeoText.TextStyle
            If objDestTextStyle Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Set objRecordset = Nothing
                  Exit Sub
            Else
                  strFontName = objDestTextStyle.FontName
                  dFontHeight = objDestTextStyle.FontHeight
                  nColor = objDestTextStyle.Color
            End If
      End If
            
      If FrmStyle.SuperMap1.ShowTextStylePicker(objDestTextStyle) = False Then
            Set objDtVector = Nothing
            Exit Sub
      End If
            
      Set objRecordset = objDtVector.Query("", True)
            
      If objRecordset Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            SuperMap1.Layers.SetEditableLayer 0
            Exit Sub
      End If
            
      objRecordset.MoveFirst
      objRecordset.Edit
      Do Until objRecordset.IsEOF
            Set objGeoText = objRecordset.GetGeometry()
            If objGeoText Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
            Else
                  Set objTextStyle = objGeoText.TextStyle
                  If objTextStyle Is Nothing Then
                        MsgBox objError.LastErrorMsg, vbInformation
                  Else
                        If (objTextStyle.FontName = strFontName) And (objTextStyle.FontHeight = dFontHeight) And (objTextStyle.Color = nColor) Then
                              Set objGeoText.TextStyle = objDestTextStyle
                        End If
                  End If
                  objRecordset.Edit
                  objRecordset.SetGeometry objGeoText
                  objRecordset.Update
                  Set objGeoText = Nothing
            End If
            objRecordset.MoveNext
      Loop
      SuperMap1.Refresh
            
      Set objDtVector = Nothing
      Set objDestTextStyle = Nothing
      Set objRecordset = Nothing
      Set objGeoText = Nothing
End Sub

Private Sub mnuSelectedText_Click()
      '修改选中注记的风格
      Dim objDtVector As soDatasetVector        '定义矢量标注数据集变量
      Dim objRecordset As soRecordset           '定义标注据路边量
      Dim objDestTextStyle As soTextStyle       '存放用户要改为的目标风格
      Dim objTextStyle As soTextStyle           '每个对象的风格，用于与用户设定的条件比较，符合条件的才修改
      Dim objGeoText  As soGeoText
      Dim i As Long
      
      If FrmStyle.SuperMap1.selection.Count = 0 Then                       '没有标注对象被选中
            MsgBox "请选中所的要修改其风格的注记！", vbInformation
            SuperMap1.Layers.SetEditableLayer 0
            SuperMap1.Action = scaSelect
            Exit Sub
      Else
            Set objDtVector = FrmStyle.SuperMap1.selection.Dataset
            If objDtVector Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
      End If
            
      Set objRecordset = FrmStyle.SuperMap1.selection.ToRecordset(True)
      If objRecordset Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Set objDtVector = Nothing
            Exit Sub
      End If

      objRecordset.MoveFirst
      If Not objRecordset.GetGeometry.Type = scgText Then Exit Sub
      Set objGeoText = objRecordset.GetGeometry()
      If objGeoText Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            SuperMap1.Layers.SetEditableLayer 0
            Exit Sub
      Else
            Set objDestTextStyle = objGeoText.TextStyle
            If objDestTextStyle Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Set objRecordset = Nothing
                  Exit Sub
            End If
      End If
            
      If FrmStyle.SuperMap1.ShowTextStylePicker(objDestTextStyle) = False Then
            Set objDtVector = Nothing
            Exit Sub
      End If
            
      Set objRecordset = FrmStyle.SuperMap1.selection.ToRecordset(True)
            
      If objRecordset Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
            
      objRecordset.MoveFirst
      objRecordset.Edit
      Do Until objRecordset.IsEOF
            Set objGeoText = objRecordset.GetGeometry()
            If objGeoText Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
            Else
                  Set objGeoText.TextStyle = objDestTextStyle
                  objRecordset.Edit
                  objRecordset.SetGeometry objGeoText
                  objRecordset.Update
                  Set objGeoText = Nothing
            End If
            objRecordset.MoveNext
      Loop
      SuperMap1.Refresh
      '释放内存
      Set objDtVector = Nothing
      Set objDestTextStyle = Nothing
      Set objRecordset = Nothing
      Set objGeoText = Nothing

End Sub