📄 frmattedit.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmattedit
BorderStyle = 3 'Fixed Dialog
Caption = "空间属性编辑"
ClientHeight = 3000
ClientLeft = 45
ClientTop = 435
ClientWidth = 7395
Icon = "frmattedit.frx":0000
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3000
ScaleWidth = 7395
ShowInTaskbar = 0 'False
Begin MSComctlLib.ListView LvwfeatureId
Height = 4935
Left = 120
TabIndex = 5
Top = 360
Width = 1335
_ExtentX = 2355
_ExtentY = 8705
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = 16711680
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.CommandButton cmdedit
Caption = "删除"
Height = 375
Index = 3
Left = 6120
TabIndex = 4
Top = 2280
Width = 600
End
Begin VB.CommandButton cmdedit
Caption = "添加"
Height = 375
Index = 2
Left = 6120
TabIndex = 3
Top = 1320
Visible = 0 'False
Width = 600
End
Begin VB.CommandButton cmdedit
Caption = "更新"
Height = 375
Index = 1
Left = 6120
TabIndex = 2
Top = 360
Width = 600
End
Begin VB.TextBox txtfldvalue
BackColor = &H8000000B&
Height = 350
Index = 0
Left = 3720
TabIndex = 1
Text = "Text1"
Top = 240
Width = 1575
End
Begin VB.Label Label1
Caption = "选择记录："
Height = 240
Left = 120
TabIndex = 6
Top = 100
Width = 1335
End
Begin VB.Label lblfldname
Caption = "Label1"
ForeColor = &H00008000&
Height = 255
Index = 0
Left = 2400
TabIndex = 0
Top = 270
Width = 975
End
End
Attribute VB_Name = "frmattedit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim i As Integer
Dim recs As MapObjects2.Recordset
Dim Desc As TableDesc
Sub showfrmattedit()
Dim Index As Integer
Index = frmmain.TuLi.getActiveLayer
If Index = -1 Then
MsgBox "当前没有活动的图层。", vbOKOnly, "停止"
Exit Sub
End If
Dim g_activelayer As Object
Set g_activelayer = frmmain.Map1.Layers(Index)
If g_activelayer.LayerType = moMapLayer Then
g_activelayer.RemoveRelates
Set recs = g_activelayer.Records
Set Desc = recs.TableDesc
End If
If recs.EOF Then
MsgBox "当前记录集为空！", vbExclamation, "操作提示"
Exit Sub
End If
Me.Show
End Sub
'Private Sub Cmdadd_Click()
'
'frmLogin.Show 1
'
'If Not txtUserName.text = "" Or txtpassword(0).text = "" Then
'
' filename = App.path & "\info\" & "adm.dat"
' Open filename For Random As #1 Len = 20
' rec_total = LOF(1) / 20
' If Not rec_total = 0 Then
' rec_no = 1
' Do While Not EOF(1)
' Get #1, rec_no, user
' If Trim(user.name) = txtUserName.text And _
' Trim(user.password) = txtpassword Then
' LoginSucceeded = True
' Unload Me
' islawedit = 1
' frmattedit.showfrmattedit
' Exit Sub
' End If
' rec_no = rec_no + 1
' Loop
'
' ElseIf LCase(txtUserName) = "hngis" And LCase(txtpassword) = "hn1508" Then
' '将代码放在这里传递
' '成功到 calling 函数
' '设置全局变量时最容易的
' LoginSucceeded = True
' Unload Me
' islawedit = 1
' frmattedit.showfrmattedit
' Else
' MsgBox "无效的密码，请重试!", , "登录"
' txtpassword.SetFocus
' SendKeys "{Home}+{End}"
' End If
'End Sub
Private Sub Cmdedit_Click(Index As Integer)
Select Case Index
Case 0
recs.CancelUpdate
Case 1
If recs.Updatable Then
On Err GoTo fals1
recs.Edit
For i = 0 To Desc.FieldCount - 1
If Desc.FieldType(i) = moString Or _
Desc.FieldType(i) = moBoolean Then
recs(Desc.FieldName(i)).Value = txtfldvalue(i + 1).Text
ElseIf Desc.FieldType(i) = moDouble Or _
Desc.FieldType(i) = moLong Then
recs(Desc.FieldName(i)).Value = Val(txtfldvalue(i + 1).Text)
ElseIf Desc.FieldType(i) = moDate Then
recs(Desc.FieldName(i)).Value = CDate(txtfldvalue(i + 1).Text)
End If
Next i
recs.Update
recs.StopEditing
End If
Exit Sub
fals1:
MsgBox "输入数据格式错误！", vbExclamation, "操作提示"
Exit Sub
Case 2
If recs.Updatable Then
recs.AddNew
End If
Case 3
If recs.Updatable Then
On Error Resume Next
recs.Delete
recs.StopEditing
frmmain.Map1.Refresh
For i = 0 To txtfldvalue.Count - 1
txtfldvalue(i).Text = ""
Next i
For i = 0 To Desc.FieldCount - 1
txtfldvalue(i + 1).Text = recs(Desc.FieldName(i)).Value
Next i
txtfldvalue(0).Text = recs("FeatureID").Value
LvwfeatureId.ListItems.Clear
recs.MoveFirst
Do While Not recs.EOF
Dim newitem As ListItem
Set newitem = LvwfeatureId.ListItems.Add()
newitem.Text = recs.Fields("FeatureId").Value
newitem.Selected = False
recs.MoveNext
DoEvents
Loop
Else
MsgBox "该图层不可编辑！", vbExclamation, "操作提示"
End If
Case 4
Dim response As String
response = MsgBox("确定要保留更新吗？", vbYesNoCancel, "提示")
If response = vbYes Then
'Do Until recs.EOF
recs.Update
ElseIf response = vbNo Then
recs.CancelUpdate
End If
recs.StopEditing
End Select
End Sub
'Private Sub cmdmove_Click(Index As Integer)
'
'Select Case Index
' Case 0
' recs.MoveFirst
' txtfldvalue(0).text = recs("FeatureId").Value
' For i = 0 To lblfldname.Count - 1
' txtfldvalue(i + 1).text = recs(desc.FieldName(i)).Value
' recs(desc.FieldName(i)).Value = txtfldvalue(i + 1).text
' Next i
' Case 1
' ' If Not recs.BOF Then
' recs.MovePrevious
' ' End If
' txtfldvalue(0).text = recs("FeatureId").Value
' For i = 0 To lblfldname.Count - 1
' txtfldvalue(i + 1).text = recs(desc.FieldName(i)).Value
' recs(desc.FieldName(i)).Value = txtfldvalue(i + 1).text
' Next i
' Case 2
' If Not recs.EOF Then
' recs.MoveNext
' End If
' txtfldvalue(0).text = recs("FeatureId").Value
' For i = 0 To lblfldname.Count - 1
' txtfldvalue(i + 1).text = recs(desc.FieldName(i)).Value
' recs(desc.FieldName(i)).Value = txtfldvalue(i + 1).text
' Next i
' Case 3
' Do Until recs.EOF
' recs.MoveNext
' Loop
' txtfldvalue(0).text = recs("FeatureId").Value
' For i = 0 To lblfldname.Count - 1
' txtfldvalue(i + 1).text = recs(desc.FieldName(i)).Value
' recs(desc.FieldName(i)).Value = txtfldvalue(i + 1).text
' Next i
'
'End Select
'
'End Sub
'-----------------------------------------------------
Private Sub Form_Load()
With LvwfeatureId
.AllowColumnReorder = False
.View = lvwReport
.Gridlines = True
.LabelEdit = lvwManual
.HideColumnHeaders = False
.ColumnHeaders.Add , , "FeatureID"
.FullRowSelect = True
.MultiSelect = False
End With
LvwfeatureId.ListItems.Clear
Do While Not recs.EOF
Dim newitem As ListItem
Set newitem = LvwfeatureId.ListItems.Add()
newitem.Text = recs.Fields("FeatureId").Value
newitem.Selected = False
recs.MoveNext
DoEvents
Loop
recs.MoveFirst
If lblfldname.Count > 1 Then
For i = (lblfldname.Count - 1) To 1 Step -1
Unload lblfldname(i)
Unload txtfldvalue(i)
Next i
End If
lblfldname(0).Caption = "FeatureID"
txtfldvalue(0).Text = recs("FeatureID").Value
txtfldvalue(0).Locked = True
For i = 0 To Desc.FieldCount - 1
Load lblfldname(i + 1)
With lblfldname(i + 1)
.Left = lblfldname(0).Left
.Width = lblfldname(0).Width
.Top = lblfldname(i).Top + 400
.Height = lblfldname(0).Height
.Caption = Desc.FieldName(i)
.Visible = True
End With
Load txtfldvalue(i + 1)
With txtfldvalue(i + 1)
.Left = txtfldvalue(0).Left
.Width = txtfldvalue(0).Width
.Top = txtfldvalue(i).Top + 400
.Height = txtfldvalue(0).Height
.Text = recs(Desc.FieldName(i)).Value
.Visible = True
If Desc.FieldName(i) = "LENGTH" Or _
Desc.FieldName(i) = "AREA" Or _
Desc.FieldName(i) = "PERIMETER" Then
.Locked = True
'.BackColor = &H8000000B
Else
.Locked = False
.BackColor = vbWhite
End If
End With
Next i
End Sub
Private Sub LvwfeatureId_Click()
recs.MoveFirst
Do While Not recs.EOF
If LvwfeatureId.SelectedItem.Text = recs("featureid").ValueAsString Then
lblfldname(0).Caption = "FeatureID"
txtfldvalue(0).Text = recs("FeatureID").Value
For i = 0 To Desc.FieldCount - 1
lblfldname(i + 1).Caption = Desc.FieldName(i)
txtfldvalue(i + 1).Text = recs(Desc.FieldName(i)).Value
Next i
frmmain.Map1.FlashShape recs("shape").Value, 3
Exit Do
End If
recs.MoveNext
Loop
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -