本程序把带坐标的DGN图层转入进SuperMap后，坐标还保留，当把线数据集转成面数据集后，Z坐标保留，为了以后面数据集
生成3D提供高程字段，同时用户可以创建字段，如本示范中创建了TEXTURE字段，以作三维贴图之用。

• DGN数据的转入

Private Sub btnOK_Click() 'DGN数据集的转入
Dim DS As soDataSource
Dim objDataPump As soDataPump '数据泵对象
Dim result As Boolean

sDsName = Form3.Combo1.Text
Set DS = Form1.Workspace.Datasources(1)
If DS Is Nothing Then
    MsgBox ("错误，数据源为空")
    Exit Sub
End If
Set objDataPump = DS.DataPump
If objDataPump Is Nothing Then
    MsgBox "数据泵为空！"
    Exit Sub
End If
With objDataPump
   .FileName = Form3.Text1.Text
   .FileType = scfDGN
   .ShowProgress = True
   .Compressed = False
   .ImportAsCADDataset = False
   .DatasetPoint = IIf(Form3.Check1.Value = vbChecked, Form3.Text2.Text, "")'//是否转入点图层
   .DatasetLine = IIf(Form3.Check2.Value = vbChecked, Form3.Text3.Text, "")'//是否转入线图层
   .DatasetRegion = IIf(Form3.Check3.Value = vbChecked, Form3.Text4.Text, "")'//是否转入面图层
   .DatasetText = IIf(Form3.Check4.Value = vbChecked, Form3.Text5.Text, "")'//是否转入文本图层
   
   Form1.Workspace.DgnColorMappingTable = Form4.Combo4.Text'颜色对照表
   Form1.Workspace.StyleMappingTable = Form4.Combo3.Text'对照表
    '取得Dgn单位
    Select Case Form4.Combo1.ListIndex
          Case 0
                objDataPump.DgnUnits = scdMain    'DGN主单位
          Case 1
                objDataPump.DgnUnits = scdSub     'DGN从单位
          Case 2
                objDataPump.DgnUnits = scdUOR     '最小分辨率
    End Select
    '取得缺省单位
    Dim defaultunits As String
    Call SetUnit(Form4.Combo2.Text, defaultunits)'调用设定单位函数
    objDataPump.defaultunits = Val(defaultunits)
End With

result = objDataPump.Import
If Not (result) Then
    MsgBox "文件转入失败！", vbInformation
    Set objDataPump = Nothing
    Exit Sub
End If

Form1.WkspManager.Refresh'更新wksaManger控件
Set DS = Nothing
Set objDataPump = Nothing
Me.Hide
End Sub

• 线数据集转成面数据集

Private Sub Command1_Click() '线数据集转成面数据集
    Dim objgeoline As soGeoLine'定义线对象变量
    Dim objgeoregion As soGeoRegion'定义面对象变量
    Dim objds As soDataSource'定义数据源变量
    Dim objDtVector As soDatasetVector'定义矢量数据集变量
    Dim objSourceRecordSet As soRecordset'定义源记录集变量
    Dim objDestRecordSet As soRecordset'定义目标记录集变量
    Dim rcbounds As soRect'定义一下bounds变量
    Dim FieldInfo As New soFieldInfo'定义一个新的字段信息变量
    Dim i As Integer

  If Form2.Text3.Text <> "" Then
     If Form1.Workspace.Datasources(1).Datasets(Form2.Text2.Text).Type <> scdLine Then
       MsgBox "请选择一个线数据集"
       Exit Sub
     Else
        '//取得源数据源的bounds
        Set objds = Form1.Workspace.Datasources.Item(Text1.Text)
        If objds Is Nothing Then                  '打开源数据源失败
              MsgBox " 打开源数据源失败"
              Exit Sub
        Else
          Set rcbounds = objds.Datasets(Text2.Text).Bounds
        End If
        '判断新数据集名称的合法性，并创建数据集
        Set objds = Form1.Workspace.Datasources(1)  '//取得目标数据源
        If objds Is Nothing Then
              MsgBox "目标数据源为空"
              Exit Sub
        ElseIf objds.IsAvailableDatasetName(Text3.Text) = False Then
              MsgBox "数据集名称非法"
              Text3.SetFocus
              Exit Sub
        Else
             Set objDtVector = objds.CreateDataset(Text3.Text, scdRegion, scoDefault, rcbounds)
        End If
        If objDtVector Is Nothing Then
             MsgBox "数据集为空"
             Exit Sub
        Else
             objDtVector.Open
             Set objDestRecordSet = objDtVector.Query("", True) '取得目标记录集
             If objDestRecordSet Is Nothing Then
                  MsgBox "目标数据集为空"
                  Exit Sub
             End If
        End If
    '取得源记录集(objSourceRecordSet)
         If objds Is Nothing Then                  '打开源数据源失败
               MsgBox "打开源数据源失败"
               Exit Sub
         Else
               Set objDtVector = objds.Datasets.Item(Text2.Text)
               If objDtVector Is Nothing Then      '打开源数据集失败
                     MsgBox "打开源数据集失败"
                     Exit Sub
               Else
                     objDtVector.Open
                     Set objSourceRecordSet = objDtVector.Query("", True)
                     If objSourceRecordSet Is Nothing Then           '查询失败
                           MsgBox "查询失败"
                           Exit Sub
                     End If
               End If
         End If         
      '把源数据集中的Z字段中的值添加到目标数据集中
        Dim objFieldInfo  As soFieldInfo
        Dim fdcount As Integer
        Dim j As Integer
        For j = 1 To objSourceRecordSet.FieldCount        '判断线数据集中是否有Z坐标字段
              Set objFieldInfo = objSourceRecordSet.GetFieldInfo(j)
              If objFieldInfo.Name = "Z" Then zflag = True
        Next j
        If zflag = True Then
            Set objDtVector = Form1.Workspace.Datasources(1).Datasets(Form2.Text3.Text)
            Set fieldname = objSourceRecordSet.GetFieldInfo("Z")
            objDtVector.ClearRecordsets

            If objDtVector.CreateField(fieldname) Then
               Set objDestRecordSet = objDtVector.Query("", True)
               fdcount = objDestRecordSet.FieldCount
            End If
        End If
    End If
End If
'//////////////////////////
'开始转换，把线数据集中的"Z坐标"也转到面数据集中
         objSourceRecordSet.MoveFirst
         objDestRecordSet.MoveFirst
               For i = 1 To objSourceRecordSet.RecordCount
                     Set objgeoline = objSourceRecordSet.GetGeometry()
                     If Not (objgeoline Is Nothing) Then
                           Set objgeoregion = objgeoline.ConvertToRegion()
                           If Not (objgeoregion Is Nothing) Then
                                objDestRecordSet.AddNew objgeoregion  '如果转换成功，则往目标数据集中添加一个
新的面对象
                                objDestRecordSet.Edit
                                objDestRecordSet.SetFieldValue fdcount, objSourceRecordSet.GetFieldValue("Z")
                                objDestRecordSet.Update
                                objSourceRecordSet.MoveNext                               
                           End If
               Next i      

      Form1.WkspManager.Refresh
   '清空释放变量  
      Set objds = Nothing
      Set objDtVector = Nothing
      Set objgeoline = Nothing
      Set objgeoregion = Nothing
      Set objSourceRecordSet = Nothing
      Set objDestRecordSet = Nothing
      Unload Me
End Sub

• 三维贴图的实现

Private Sub Command1_Click()
      Dim objlayer As soLayer
      Dim dMultiple As Double
      
      If Trim$(cmbLayerName.Text) = "" Then
            MsgBox "图层名为空！"
            Exit Sub
      End If
      Set objlayer = Form1.map.Layers(1)
      If objlayer Is Nothing Then
            MsgBox "程序内部错误！", vbInformation
            Exit Sub
      End If
      Form7.Super3D.ActiveDataset = objlayer.Dataset '设定要建立三维的数据集
      Form7.Super3D.Visible = True
       If objlayer.Dataset.Type = scdRegion Then
            Form7.Super3D.AltitudeField = cmbFieldZ.Text  '设定高程字段
            If Trim$(txtScaleZ.Text) = "" Then
                  dMultiple = "1.0"
            ElseIf Val(Trim$(txtScaleZ.Text)) = "0.000000" Then
                  dMultiple = "1.0"
            Else
                  dMultiple = CDbl(txtScaleZ.Text)
            End If
            Form7.Super3D.ScaleZ = dMultiple '设定高程缩放比例
      End If
      Unload Me
      Form7.Show
      Set objlayer = Nothing
End Sub