frmcreatebuffer.frm

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

                Case scdNetwork
                    iImgIndex = 3
                Case scdTIN
                    iImgIndex = 6
                Case scdECW
                    iImgIndex = 16
                Case scdMrSID
                    iImgIndex = 17
                Case Else
                      iImgIndex = 7
            End Select

            FrmMain.tvwData.Nodes.Add FrmMain.SuperWorkspace1.Datasources.Item(cmbDsName.Text).Alias, tvwChild, , txtNewDtName.Text, iImgIndex
            
            cmbDtName.AddItem objDt.Name
            cmbDtName.Text = objDt.Name
            Set objDt = Nothing
            '目标记录集
            Set objDtVector = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsName.Text).Datasets.Item(cmbDtName.Text)
            If objDtVector Is Nothing Then
                MsgBox "数据集" & cmbDtName.Text & "错误！", vbInformation
                Exit Sub
            End If
            objDtVector.Open
            Set DestRecordSet = objDtVector.Query("", False)
            If DestRecordSet Is Nothing Then
                MsgBox "Query " & "错误！", vbInformation
                Exit Sub
            End If
            DestRecordSet.MoveLast
            '源记录集
            Set RecordSet = FrmMain.SuperMap1.selection.ToRecordset(False)
            If RecordSet Is Nothing Then
                MsgBox "错误！", vbInformation
                Exit Sub
            End If
            RecordSet.MoveFirst
            Set objSourceGeomtry = RecordSet.GetGeometry()
            If objSourceGeomtry Is Nothing Then
                MsgBox "错误！", vbInformation
                Exit Sub
            End If
        Else
            Set objDt = Nothing
            MsgBox "数据集创建失败!", vbInformation
            Exit Sub
        End If
    Else                                                             '使用旧数据集
        If cmbDtName.Text = "" Then
            MsgBox "请给出数据集名称！", vbInformation
            Exit Sub
            If cmbDtName.ListCount = 0 Then
                chkNewDt.Value = 1
                chkNewDt.Enabled = False
                txtNewDtName.Enabled = True
                txtNewDtName.BackColor = &H80000005
                txtNewDtName.SetFocus
                cmbDtName.Enabled = False
                cmbDtName.BackColor = &H80000004
            Else
                cmbDtName.SetFocus
            End If
            Exit Sub
        End If
        Set RecordSet = FrmMain.SuperMap1.selection.ToRecordset(False)
        If RecordSet Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
        End If
        RecordSet.MoveFirst
        Set objSourceGeomtry = RecordSet.GetGeometry()
        If objSourceGeomtry Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
        End If
        Set objDtVector = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsName.Text).Datasets.Item(cmbDtName.Text)
        If objDtVector Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
        End If
        objDtVector.Open
        Set DestRecordSet = objDtVector.Query("", True)
        If DestRecordSet Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
        End If
    End If
    '生成缓冲区
    bFirst = True
    Do
        If optRadius = True Then                      '指定半径
            Set objDestGeomtry = objSourceGeomtry.Buffer(CDbl(txtRadius.Text) * 1000, CInt(txtArc.Text))
        Else                                          '使用字段值作半径
            Set objDestGeomtry = objSourceGeomtry.Buffer(CDbl(RecordSet.GetFieldValue(cmbField.Text)) * 1000, CInt(txtArc.Text))
        End If
        If Not (objDestGeomtry Is Nothing) Then
            If (optAll = True) Then                 '为所有对象创建一个缓冲区,还要继续对生的Buffer求并(Region求并)
                If bFirst Then
                    Set objAllGeomtry = objDestGeomtry
                    bFirst = False
                Else
                    Set objAllGeomtry = objAllGeomtry.Union(objDestGeomtry)
                End If
                If objAllGeomtry Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
            Else
                DestRecordSet.AddNew objDestGeomtry
                DestRecordSet.Update
            End If
        End If
        RecordSet.MoveNext
        Set objSourceGeomtry = RecordSet.GetGeometry()
        Do While (objSourceGeomtry Is Nothing) And (Not (RecordSet.IsEOF))
            RecordSet.MoveNext
            Set objSourceGeomtry = RecordSet.GetGeometry()
        Loop
    Loop Until RecordSet.IsEOF
    If optAll = True Then
        DestRecordSet.AddNew objAllGeomtry
        DestRecordSet.Update
    End If
    DestRecordSet.Close
    Set objSourceGeomtry = Nothing
    Set objDestGeomtry = Nothing
    Set objAllGeomtry = Nothing
    Set RecordSet = Nothing
    Set DestRecordSet = Nothing
    Set objDtVector = Nothing
    FrmMain.SuperMap1.Refresh
    Unload Me
End Sub

Private Sub chkNewDt_Click()
    If chkNewDt.Value = 1 Then
        cmbDtName.Enabled = False
        cmbDtName.BackColor = &H80000004
        lblNewDtName.Enabled = True
        txtNewDtName.Enabled = True
        txtNewDtName.BackColor = &H80000005
    Else
        cmbDtName.Enabled = True
        cmbDtName.BackColor = &H80000005
        lblNewDtName.Enabled = False
        txtNewDtName.Enabled = False
        txtNewDtName.BackColor = &H80000004
    End If
End Sub

Private Sub cmbDsName_Click()
    '添加数据集列表
    Dim DS As soDataSource
    Dim objDt As soDataset
    Dim i As Integer
      
    Set DS = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsName.Text)
    If DS Is Nothing Then
        MsgBox "数据源" & cmbDsName.Text & "错误！", vbInformation
        Exit Sub
    End If
    cmbDtName.Clear
    For Each objDt In DS.Datasets
        If objDt.Type = scdRegion Then
            cmbDtName.AddItem objDt.Name
        End If
    Next
    
    Set objDt = FrmMain.SuperMap1.selection.Dataset
    If objDt Is Nothing Then
        MsgBox "打开数据集时出错！", vbInformation
        Exit Sub
    End If
    If (objDt.Type = scdRegion) Then
        For i = 0 To cmbDtName.ListCount - 1
            If cmbDtName.List(i) = objDt.Name Then
                cmbDtName.Text = objDt.Name
                cmbDtName.Enabled = True
                cmbDtName.BackColor = &H80000005
                chkNewDt.Value = vbUnchecked
                chkNewDt.Enabled = True
                Exit For
            End If
        Next
    ElseIf (cmbDtName.ListCount > 0) Then
        cmbDtName.ListIndex = 0
        cmbDtName.Enabled = True
        cmbDtName.BackColor = &H80000005
        chkNewDt.Value = vbUnchecked
        chkNewDt.Enabled = True

    Else
        cmbDtName.Enabled = False
        cmbDtName.BackColor = &H80000004
        chkNewDt.Value = 1
        chkNewDt.Enabled = False
    End If
    
    Set DS = Nothing
    Set objDt = Nothing
End Sub

Private Sub Form_Load()
      
    Dim objRecordset As soRecordset
    Dim objFieldInfos As soFieldInfos
    Dim objFieldInfo As soFieldInfo
    '添加字段列表
    Set objRecordset = FrmMain.SuperMap1.selection.ToRecordset(False)
    If objRecordset Is Nothing Then
        MsgBox "错误！", vbInformation
        Exit Sub
    End If
    Set objFieldInfos = objRecordset.GetFieldInfos()
    For Each objFieldInfo In objFieldInfos
        Select Case objFieldInfo.Type
            Case scfDouble, scfInteger, scfLong, scfSingle
                cmbField.AddItem objFieldInfo.Name
            Case Else
              
        End Select
    Next
    If cmbField.ListCount > 0 Then
        cmbField.ListIndex = 0
    End If
    Set objFieldInfos = Nothing
    Set objRecordset = Nothing
    '添加目标数据源列表
    Dim objDS As soDataSource
    For Each objDS In FrmMain.SuperWorkspace1.Datasources
        cmbDsName.AddItem objDS.Alias
    Next
    cmbDsName.Text = FrmMain.SuperMap1.selection.Dataset.DataSourceAlias
      
    '添加单位列表
    With cmbUnit
        .AddItem "千米"
        .AddItem "米"
        .AddItem "分米"
        .AddItem "厘米"
        .AddItem "毫米"
        .AddItem "里"
        .AddItem "码"
        .AddItem "英尺"
        .AddItem "英寸"
        .ListIndex = 0
    End With
    'Buffer的半径值
    txtRadius.Text = 1
End Sub

Private Sub optFieldVal_Click()                            '使用字段值
    If optFieldVal.Value = True Then
        cmbField.Enabled = True
        cmbField.BackColor = &H80000005
        txtRadius.Enabled = False
        txtRadius.BackColor = &H80000004
    End If
End Sub

Private Sub optRadius_Click()                               '指 定 半 径
    If optRadius.Value = True Then
        txtRadius.BackColor = &H80000005
        txtRadius.Enabled = True
        cmbField.Enabled = False
        cmbField.BackColor = &H80000004
    End If
End Sub

Private Sub txtNewDtName_LostFocus()
    Dim Result As VbMsgBoxResult
    If Trim$(txtNewDtName.Text) <> "" Then
        Dim strDtName As String
        Dim i As Integer
        txtNewDtName.Text = Trim$(txtNewDtName.Text)     '去除首位空格
        If InStr(txtNewDtName.Text, " ") <> 0 Then       '去除中间空格
            txtNewDtName.Text = Left$(txtNewDtName.Text, InStr(txtNewDtName.Text, " ") - 1)
        End If
        strDtName = UCase$(txtNewDtName.Text)
        For i = 0 To cmbDtName.ListCount - 1
            cmbDtName.ListIndex = i
            If UCase$(cmbDtName.Text) = strDtName Then
                MsgBox "所选数据源中有同名数据集.请改名!", vbInformation
                txtNewDtName.SetFocus
                Exit Sub
            End If
        Next
    End If
End Sub