frmmodifystructure.frm

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

    txtFieldName.SetFocus
End Sub

Private Sub btnLayerAttribSave_Click() '保存所做修改
    '关闭要修改其表结构的数据集，这里简单处理关闭全部的图层
    frmMain.SuperMap.Layers.RemoveAll
    frmMain.SuperMap.Refresh
    
    Dim strDefaultValue As String
    Dim strFieldLen As String
    
    '选择必填字段,必须给出字段缺省值
    If chkRequired.Value = 1 Then
        If cmbFieldType.Text <> "dbBoolean" Then
            strDefaultValue = Trim(txtDefault.Text)
            If strDefaultValue = "" Then
                MsgBox "请给出字段的缺省值！", vbInformation
                Exit Sub
            End If
        End If
    End If
    
    '字段长度不能为零或空，否则提示"字段名非法"
    If txtFieldLen.Enabled = True Then
        strFieldLen = Trim$(txtFieldLen.Text)
        If strFieldLen = "" Then
            MsgBox "字段长度不能为空！", vbInformation
            Exit Sub
        End If
        If strFieldLen = "0" Then
            MsgBox "字段长度不能为0！", vbInformation
            Exit Sub
        End If
    End If
    
    Dim objDs As soDataSource
    Dim objDtVector As soDatasetVector
    Dim strFieldName As String
    
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(1)
    If objDs Is Nothing Then
        MsgBox "错误！", vbInformation
        Exit Sub
    End If
    Set objDtVector = objDs.Datasets.Item(frmMain.cmbDataset.Text)
    If objDtVector Is Nothing Then
        MsgBox "错误！", vbInformation
        Exit Sub
    End If
    
    '检查字段名是否合法
    strFieldName = Trim$(txtFieldName.Text)
    If Not (objDtVector.IsAvailableFieldName(strFieldName)) Then
        MsgBox "字段名非法！", vbInformation
        Exit Sub
    End If
    
    '创建新字段
    Dim objFieldInfo As New soFieldInfo
    Dim strFieldType As String
    
    '以下一段代码是为FieldInfo的各个属性赋值
    objFieldInfo.Name = strFieldName
    strFieldType = cmbFieldType.Text
    GetFieldType objFieldInfo, strFieldType, strFieldLen
    
    If strFieldType = "dbBoolean" Then
        objFieldInfo.DefaultValue = cmbDefault.Text '缺省值
        objFieldInfo.AllowZeroLength = False
    Else
        objFieldInfo.DefaultValue = strDefaultValue
    End If
    If chkAllowNull.Enabled = True Then             '零长度允许
        objFieldInfo.AllowZeroLength = IIf(chkAllowNull = 1, True, False)
    End If
    If (cmbFieldType.Text = "dbText") Or (cmbFieldType.Text = "dbBoolean") Then
        objFieldInfo.AutoIncremental = False        'Text型和Boolean型字段自动编号必为False
    Else
        objFieldInfo.AutoIncremental = IIf(chkAutomatic = 1, True, False)     '自动排序
    End If
    
    objFieldInfo.Descending = IIf(chkDescending = 1, True, False)                    '降序
    objFieldInfo.Required = IIf(chkRequired = 1, True, False)                        '必填字段
    
    '创建字段
    objDtVector.ClearRecordsets       'CreateField之前，关闭记录集，这一步很重要
    Dim bResult As Boolean
    
    bResult = objDtVector.CreateField(objFieldInfo)
    If bResult Then        '新建成功
        '加入到FieldInfo列表中
        With lsvFieldInfo
            .ListItems.Add , , objFieldInfo.Name
            Select Case objFieldInfo.Type
            Case scfBoolean
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Boolean"
            Case scfByte
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Byte"
            Case scfInteger
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Integer"
            Case scfLong
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Long"
            Case scfCurrency
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Currency"
            Case scfSingle
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Single"
            Case scfDouble
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Double"
            Case scfDate
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Date"
            Case scfText
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Text"
            Case scfLongBinary
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "LongBinary"
            Case scfMemo
                .ListItems.Item(objDtVector.FieldCount).SubItems(1) = "Memo"
            End Select
                .ListItems.Item(objDtVector.FieldCount).SubItems(2) = objFieldInfo.Size
                .ListItems.Item(objDtVector.FieldCount).SubItems(3) = objFieldInfo.DefaultValue
                .ListItems.Item(objDtVector.FieldCount).SubItems(4) = objFieldInfo.AutoIncremental
                .ListItems.Item(objDtVector.FieldCount).SubItems(5) = objFieldInfo.Descending
                .ListItems.Item(objDtVector.FieldCount).SubItems(6) = objFieldInfo.Required
                .ListItems.Item(objDtVector.FieldCount).SubItems(7) = objFieldInfo.AllowZeroLength
        End With
    Else
        MsgBox "创建字段失败", vbInformation
    End If
    
    btnLayerAttribDel.Enabled = False
    btnLayerAttribSave.Enabled = False
    txtFieldName.Enabled = False
    txtFieldName.Text = ""
End Sub

Private Sub GetFieldType(ByRef objFieldInfo As soFieldInfo, FieldType As String, FieldLen As String)
    Select Case FieldType
        Case "dbBoolean"
            objFieldInfo.Type = scfBoolean
            objFieldInfo.Size = 1
        Case "dbByte"
            objFieldInfo.Type = scfByte
            objFieldInfo.Size = 1
        Case "dbInteger"
            objFieldInfo.Type = scfInteger
            objFieldInfo.Size = 2
        Case "dbLong"
            objFieldInfo.Type = scfLong
            objFieldInfo.Size = 4
        Case "dbCurrency"
            objFieldInfo.Type = scfCurrency
            objFieldInfo.Size = 8
        Case "dbSingle"
            objFieldInfo.Type = scfSingle
            objFieldInfo.Size = 4
        Case "dbDouble"
            objFieldInfo.Type = scfDouble
            objFieldInfo.Size = 8
        Case "dbDate"
            objFieldInfo.Type = scfDate
            objFieldInfo.Size = 8
        Case "dbText"
            objFieldInfo.Type = scfText
            objFieldInfo.Size = CInt(FieldLen)
        Case "dbLongBinary"
            objFieldInfo.Type = scfLongBinary
        Case "dbMemo"
            objFieldInfo.Type = scfMemo
    End Select
End Sub

Private Sub chkAllowNull_GotFocus() '零长度允许
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub chkAutomatic_GotFocus() '自动编号
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub chkDescending_GotFocus() '降序排列
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub chkRequired_GotFocus() '必填字段
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub cmbDefault_Change() '缺省值
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub cmbFieldType_Click() '选择创建字段的类型
    Dim strType As String
    
    strType = cmbFieldType.Text
    
    Select Case strType
        Case "dbBoolean"
            txtDefault.Visible = False
            txtDefault.Enabled = False
            txtDefault.BackColor = &H80000004
            cmbDefault.Visible = True
            cmbDefault.Enabled = True
            cmbDefault.BackColor = &H80000005
            txtFieldLen.Enabled = False
            txtFieldLen.BackColor = &H80000004
            chkAllowNull.Enabled = False
            chkAutomatic.Enabled = False
        Case "dbText"
            cmbDefault.Visible = False
            cmbDefault.Enabled = False
            cmbDefault.BackColor = &H80000004
            txtDefault.Visible = True
            txtDefault.Enabled = True
            txtDefault.BackColor = &H80000005
            txtFieldLen.Enabled = True
            txtFieldLen.BackColor = &H80000005
            chkAllowNull.Enabled = True
            chkAutomatic.Enabled = False
        Case "dbLong"
            cmbDefault.Visible = False
            cmbDefault.Enabled = False
            cmbDefault.BackColor = &H80000004
            txtDefault.Visible = True
            txtDefault.Enabled = True
            txtDefault.BackColor = &H80000005
            txtFieldLen.Enabled = False
            txtFieldLen.BackColor = &H80000004
        Case Else
            cmbDefault.Visible = False
            cmbDefault.Enabled = False
            cmbDefault.BackColor = &H80000004
            txtDefault.Visible = True
            txtDefault.Enabled = True
            txtDefault.BackColor = &H80000005
            txtFieldLen.Enabled = False
            txtFieldLen.BackColor = &H80000004
            chkAllowNull.Enabled = True
            chkAutomatic.Enabled = True
    End Select
End Sub

Private Sub cmbFieldType_GotFocus() '设置为不可删除,删除按钮为灰色
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub Form_Load()
    Dim objDs As soDataSource
    Dim strName As String
    Dim objDtVector As soDatasetVector
    
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(1)
    If objDs Is Nothing Then
        MsgBox "错误！", vbInformation
        Exit Sub
    End If
    
    strName = frmMain.cmbDataset.Text
    Set objDtVector = objDs.Datasets.Item(strName)
    If objDtVector Is Nothing Then
        MsgBox "错误！", vbInformation
        Exit Sub
    End If
   
    '添加字段信息页的lsvFieldInfo
    Dim objFieldInfo As soFieldInfo
    Dim i As Integer
    
    For i = 1 To objDtVector.FieldCount
        Set objFieldInfo = objDtVector.GetFieldInfo(i)
        If objFieldInfo Is Nothing Then
            MsgBox "字段错误！", vbInformation
        Else
            lsvFieldInfo.ListItems.Add , , objFieldInfo.Name
            Select Case objFieldInfo.Type
                Case scfBoolean
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Boolean"
                Case scfByte
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Byte"
                Case scfInteger
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Integer"
                Case scfLong
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Long"
                Case scfCurrency
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Currency"
                Case scfSingle
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Single"
                Case scfDouble
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Double"
                Case scfDate
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Date"
                Case scfText
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Text"
                Case scfLongBinary
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "LongBinary"
                Case scfMemo
                    lsvFieldInfo.ListItems.Item(i).SubItems(1) = "Memo"
            End Select
            
            lsvFieldInfo.ListItems.Item(i).SubItems(2) = objFieldInfo.Size
            lsvFieldInfo.ListItems.Item(i).SubItems(3) = objFieldInfo.DefaultValue
            lsvFieldInfo.ListItems.Item(i).SubItems(4) = objFieldInfo.AutoIncremental
            lsvFieldInfo.ListItems.Item(i).SubItems(5) = objFieldInfo.Descending
            lsvFieldInfo.ListItems.Item(i).SubItems(6) = objFieldInfo.Required
            lsvFieldInfo.ListItems.Item(i).SubItems(7) = objFieldInfo.AllowZeroLength
        End If
    Next
    
    '添加数据集属性页的cmbFieldType列表框
    With cmbFieldType
        .AddItem "dbBoolean"
        .AddItem "dbByte"
        .AddItem "dbInteger"
        .AddItem "dbLong"
        .AddItem "dbCurrency"
        .AddItem "dbSingle"
        .AddItem "dbDouble"
        .AddItem "dbDate"
        .AddItem "dbBinary"
        .AddItem "dbText"
        .AddItem "dbLongBinary"
        .AddItem "dbMemo"
        .AddItem "dbGUID"
        .ListIndex = 0
    End With
    
    cmbDefault.AddItem "True"
    cmbDefault.AddItem "False"
    cmbDefault.ListIndex = 0
    cmbDefault.Enabled = False
    cmbDefault.BackColor = &H80000004
End Sub

Private Sub lsvFieldInfo_ItemClick(ByVal Item As MSComctlLib.ListItem)
    If Left$(Trim$(Item), 2) <> "Sm" Then
        btnLayerAttribDel.Enabled = True
    Else  '系统字段，不可编辑，不可删除
        btnLayerAttribDel.Enabled = False
    End If
End Sub

Private Sub txtDefault_GotFocus()
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub txtFieldLen_GotFocus()
    btnLayerAttribDel.Enabled = False
End Sub

Private Sub txtFieldLen_KeyPress(KeyAscii As Integer) '输入字段长度
    If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
        If KeyAscii <> vbKeyBack Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub

Private Sub txtFieldLen_LostFocus()
    If Left(Trim$(txtFieldLen.Text), 1) = "0" Then
        txtFieldLen.Text = Right$(txtFieldLen.Text, Len(txtFieldLen.Text) - 1)
    End If
End Sub

Private Sub txtFieldName_Change()
    If Trim$(txtFieldName.Text) <> "" Then btnLayerAttribSave.Enabled = True
End Sub

Private Sub txtFieldName_GotFocus()
    btnLayerAttribDel.Enabled = False
End Sub