frmimportdatasource2_v.frm

超图的文件的导入与导出VB开发程序的应用,对地理信息系统开发有益

      Y1              =   3330
      Y2              =   3330
   End
End
Attribute VB_Name = "frmImportDs2_V"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'============================================================================
' 转入向导第二步,转入矢量文件.本步获得转入图层类型,即转入为CAD图层,还是GIS图层,
' 同时获得CAD图层名,或GIS的点图层、线图层、面图层、注记图层名。源文件使用的单位。
' 若是DGN文件则调用下一步向导,其余文件则,向导结束,开始转入.
'============================================================================

Private Sub btnBack_Click()
    Unload Me
    frmImportDs1.Show
End Sub

Private Sub btnCancel_Click()
    Unload Me
    Unload frmImportDs1
End Sub

Private Sub btnNext_Click()
    Dim objDS As soDataSource
    Dim strDsName As String
    Dim strNameErr As String
    strDsName = frmImportDs1.cmbImportTo.Text     '从上一步获取数据源文件名strDsName
    Set objDS = frmMain.SuperWorkspace1.Datasources.Item(strDsName)
    If objDS Is Nothing Then
        MsgBox "数据源" & strDsName & "内部错误，无法继续!", vbInformation
        Exit Sub
    End If

    If optGISLayer.Value = True Then
        If (chkLine.Value <> 1) And (chkPoint.Value <> 1) And (chkRegion.Value <> 1) And (chkText.Value <> 1) Then
            MsgBox "请选择要转为GIS的何种图层？", vbQuestion
            Exit Sub
        End If
        If (chkPoint.Value = 1) And (objDS.IsAvailableDatasetName(txtGISPoint.Text) = False) Then strNameErr = "点"
        If (chkLine.Value = 1) And (objDS.IsAvailableDatasetName(txtGISLine.Text) = False) Then strNameErr = strNameErr & "线"
        If (chkRegion.Value = 1) And (objDS.IsAvailableDatasetName(txtGISRegion.Text) = False) Then strNameErr = strNameErr & "面"
        If (chkText.Value = 1) And (objDS.IsAvailableDatasetName(txtGISText.Text) = False) Then strNameErr = strNameErr & "注记"
    Else
        If objDS.IsAvailableDatasetName(txtCADLayer.Text) = False Then
            MsgBox "CAD图层名非法!", vbInformation
            Set objDS = Nothing
            Exit Sub
        End If
    End If
    If Len(strNameErr) > 0 Then
        MsgBox strNameErr & "图层名非法！", vbInformation
        Set objDS = Nothing
        Exit Sub
    End If
    
    Dim bResult As Boolean                      '转入成功与否的标志
    Dim objDtPump As soDataPump
    Dim objImpParam As soImportParams
    Dim i As Integer
    i = objDS.Datasets.Count
    Set objDtPump = objDS.DataPump
    Set objImpParam = objDtPump.DataImportParams
    
    If objImpParam Is Nothing Then
        MsgBox "导入参数对象获取 " & "内部错误，无法继续!", vbInformation
        Set objDS = Nothing
        Exit Sub
    End If
    objImpParam.FileName = frmImportDs1.txtImportFile.Text
    If optCADLayer.Value Then
        objImpParam.ImportAsCADDataset = True
        objImpParam.DatasetCAD = LTrim$(RTrim$(txtCADLayer.Text))
    End If
    objImpParam.DatasetLine = IIf(chkLine.Value = 1, LTrim$(RTrim$(txtGISLine.Text)), "")
    objImpParam.DatasetPoint = IIf(chkPoint.Value = 1, LTrim$(RTrim$(txtGISPoint.Text)), "")
    objImpParam.DatasetRegion = IIf(chkRegion.Value = 1, LTrim$(RTrim$(txtGISRegion.Text)), "")
    objImpParam.DatasetText = IIf(chkText.Value = 1, LTrim$(RTrim$(txtGISText.Text)), "")
    objImpParam.ToleranceGrain = 0.0002    '容限
    '单位处理
    Select Case cmbUnit.Text
        Case "度"
            objImpParam.SrcDefaultUnits = scuDegree
        Case "千米"
            objImpParam.SrcDefaultUnits = scuKilometer
        Case "米"
            objImpParam.SrcDefaultUnits = scuMeter
        Case "分米"
            objImpParam.SrcDefaultUnits = scuDecimeter
        Case "厘米"
            objImpParam.SrcDefaultUnits = scuCentimeter
        Case "毫米"
            objImpParam.SrcDefaultUnits = scuMillimeter
        Case "里"
            objImpParam.SrcDefaultUnits = scuMile
        Case "码"
            objImpParam.SrcDefaultUnits = scuYard
        Case "英尺"
            objImpParam.SrcDefaultUnits = scuFoot
        Case "英寸"
            objImpParam.SrcDefaultUnits = scuInch
    End Select
    Select Case frmImportDs1.cmbFileType.ListIndex
        Case 0                         '"MapInfo 交换文件 (*.mif)|*.mif"
            objImpParam.FileType = scfMIF
        Case 1                         '"MapInfo 表文件 (*.tab)
            objImpParam.FileType = scfTAB
        Case 2                         '"MicroStation dgn 文件(*.dgn)|*.dgn"
            Me.Hide
            frmImportDs3_Dgn.Show vbModal, frmMain
            Exit Sub
        Case 3                         '"Arc/Info E00 文件 (*.e00)|*.e00"
            objImpParam.FileType = scfE00
            If chkNodesAttribTable.Value = vbChecked Then
                objImpParam.DatasetNoneGeometry = txtNodesAttribTable.Text
            End If
        Case 4                         '"ArcView Shape 文件 (*.shp)|*.shp"
            objImpParam.FileType = scfSHP
        Case 5                         '"Arc/Info Coverage 文件 (Arc.*)|arc*.*"
            objImpParam.FileType = scfCoverage
            objImpParam.DatasetNoneGeometry = txtNodesAttribTable.Text
        Case 6                         '"国标矢量交换文件 (*.vct)|*.vct"
            objImpParam.FileType = scfVCT
        Case 7                         '"idrisi矢量交换文件 (*.vce)|*.vec"
            objImpParam.FileType = scfVEC
        Case 8                         '"AutoCAD 交换文件(*.dxf)|*.dxf"
            objImpParam.FileType = scfDXF
        Case 9
            objDtPump.FileType = scfWMF
    End Select
    bResult = objDtPump.Import
    If bResult Then
        '添加TreeView节点
        i = i + 1
        Do While i <= objDS.Datasets.Count
            Select Case objDS.Datasets.Item(i).Type
                Case scdPoint
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdLine
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdRegion
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdText
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdNetwork
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdImage
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdCAD
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case scdTabular
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
                Case Else
                    frmMain.tvwSpace.Nodes.Add "A" & frmImportDs1.cmbImportTo.Text, tvwChild, , objDS.Datasets.Item(i).Name
            End Select
            i = i + 1
        Loop
        frmMain.tvwSpace.SelectedItem = frmMain.tvwSpace.Nodes.Item(3)
    Else
        MsgBox "文件转入失败!", vbInformation
    End If
    Set objDS = Nothing
    Set objImpParam = Nothing
    Set objDtPump = Nothing
    Unload frmImportDs1
    Unload Me
End Sub

Private Sub chkLine_Click()
    If chkLine = 1 Then
        txtGISLine.Enabled = True
        txtGISLine.BackColor = &H80000005
        txtGISLine.SetFocus
    Else
        txtGISLine.Enabled = False
        txtGISLine.BackColor = &H80000004
    End If
End Sub

Private Sub chkNodesAttribTable_Click()
    If chkNodesAttribTable.Value = vbChecked Then
        txtNodesAttribTable.Enabled = True
        txtNodesAttribTable.BackColor = &H80000005
        txtNodesAttribTable.SetFocus
    Else
        txtNodesAttribTable.Enabled = False
        txtNodesAttribTable.BackColor = &H80000004
    End If
End Sub

Private Sub chkPoint_Click()
    If chkPoint = 1 Then
        txtGISPoint.Enabled = True
        txtGISPoint.BackColor = &H80000005
        txtGISPoint.SetFocus
    Else
        txtGISPoint.Enabled = False
        txtGISPoint.BackColor = &H80000004
    End If
End Sub

Private Sub chkRegion_Click()
    If chkRegion = 1 Then
        txtGISRegion.Enabled = True
        txtGISRegion.BackColor = &H80000005
        txtGISRegion.SetFocus
    Else
        txtGISRegion.Enabled = False
        txtGISRegion.BackColor = &H80000004
    End If
End Sub

Private Sub chkText_Click()
    If chkText = 1 Then
        txtGISText.Enabled = True
        txtGISText.BackColor = &H80000005
        txtGISText.SetFocus
    Else
        txtGISText.Enabled = False
        txtGISText.BackColor = &H80000004
    End If
End Sub

Private Sub Form_Load()
    With cmbUnit
        .AddItem "千米"
        .AddItem "米"
        .AddItem "分米"
        .AddItem "厘米"
        .AddItem "毫米"
        .AddItem "里"
        .AddItem "码"
        .AddItem "英尺"
        .AddItem "英寸"
        .AddItem "数据集打开失败!"
        .ListIndex = 1
    End With
    Dim sTemp As String
    sTemp = PathToName(frmImportDs1.txtImportFile)
    txtCADLayer.Text = sTemp & "_CAD"
    txtGISPoint.Text = sTemp & "_Point"
    txtGISLine.Text = sTemp & "_Line"
    txtGISRegion.Text = sTemp & "_Region"
    txtGISText.Text = sTemp & "_Text"
    chkStyle.Enabled = False
    If UCase$(Right$(frmImportDs1.txtImportFile.Text, 3)) <> "DGN" Then btnNext.Caption = "完  成[&O]"
End Sub

Private Sub optCADLayer_Click()
    FrameGISLayer.Visible = False
    FrameCADLayer.Visible = True
    chkStyle.Enabled = True
    txtCADLayer.Text = PathToName(frmImportDs1.txtImportFile) & "_CAD"
    txtCADLayer.SetFocus
End Sub

Private Sub optGISLayer_Click()
    FrameCADLayer.Visible = False
    chkStyle.Enabled = False
    FrameGISLayer.Visible = True
End Sub