📄 frmdata.frm
字号:
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 240
TabIndex = 28
Top = 2400
Width = 1470
End
Begin VB.Label Label10
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "建 筑 面 积"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 720
TabIndex = 27
Top = 3600
Width = 1095
End
Begin VB.Label Label25
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "建 筑 层 数"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 720
TabIndex = 26
Top = 4200
Width = 1095
End
Begin VB.Label Label11
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "西至"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 240
Left = 6600
TabIndex = 25
Top = 3600
Width = 450
End
Begin VB.Label Label8
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "南至"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 240
Left = 6600
TabIndex = 24
Top = 4200
Width = 450
End
Begin VB.Label Label5
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "北至"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 240
Left = 6600
TabIndex = 23
Top = 4800
Width = 450
End
Begin VB.Label Label4
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "东至"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 240
Left = 6600
TabIndex = 22
Top = 3000
Width = 450
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "土地使用证号"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 5760
TabIndex = 21
Top = 1200
Width = 1350
End
Begin VB.Label Label23
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "号"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 4800
TabIndex = 20
Top = 600
Width = 225
End
Begin VB.Label Label22
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "日 期"
BeginProperty Font
Name = "Microsoft Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 1320
TabIndex = 19
Top = 4800
Width = 495
End
End
End
Attribute VB_Name = "frmData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private blnChange As Boolean
Private Sub cmdPrint_Click()
If MsgBox("确定打印吗？", vbQuestion + vbYesNo, "问题") = vbYes Then
TextPrint frmA
End If
End Sub
Private Sub cmdAdd_Click()
'Dim fso As New FileSystemObject
'Dim file1, file2 As File
'Dim ts As TextStream
Dim strbhqz As String
On Error GoTo ErrOpenFile
Call ClearFrm(Me) '清除窗体
'Set file1 = fso.OpenTextFile(App.Path & "\zjqz.txt")
'Set file2 = fso.GetFile(App.Path & "\zjqz.txt")
'Set ts = file2.OpenAsTextStream(ForReading)
Open "zjqz.txt" For Input As #1
Input #1, strbhqz
txtFrmData(0).Text = strbhqz
txtFrmData(1).SetFocus
'cmdAdd.Enabled = False
Exit Sub
ErrOpenFile:
MsgBox err.Description, vbExclamation + vbOKOnly, "打开前缀文件错误"
End
End Sub
Private Sub cmdClear_Click()
Call ClearFrm(Me)
'cmdAdd.Enabled = True
End Sub
Private Sub cmdDelete_Click()
Dim strQuery As String '查询各表中是否存在
Dim strSQL As String '执行删除操作的SQL语句
Dim strPrompt As String '提示信息
Dim strDelKey As String '要删除的案例编号
Dim rst As ADODB.Recordset
If txtFrmData(1).Text = "" Then
Call ClearFrm(Me)
Exit Sub
End If
strDelKey = Trim(txtFrmData(1).Text)
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
strQuery = "select * from 基本情况 where 编号='" & strDelKey & "'"
rst.Open strQuery, myDB, adOpenForwardOnly, adLockReadOnly
If Not rst.EOF Then
strPrompt = "确定删除编号=" & strDelKey & "的记录吗?"
If MsgBox(strPrompt, vbYesNo + vbQuestion, "问题") = vbYes Then
strSQL = "delete from 基本情况 where 编号='" & strDelKey & "'" '实例库表
myDB.Execute strSQL
MsgBox "记录被成功删除", vbInformation, "提示"
Call ClearFrm(Me)
End If
Else
strPrompt = "你要删除的记录不存在!"
MsgBox strPrompt, vbOKOnly, "提示"
Call ClearFrm(Me)
End If
rst.Close
Set rst = Nothing
End Sub
Private Sub cmdSave_Click()
Dim rst As ADODB.Recordset
Dim strSQL, strLs As String
On Error GoTo err
Set rst = New ADODB.Recordset
If Trim(txtFrmData(1).Text) = "" Then
MsgBox "编号不能为空，请先添加或输入编号！", vbOKOnly + vbInformation, "提示"
txtFrmData(1).SetFocus
Exit Sub
End If
If Trim(txtFrmData(11).Text) = "" Then
MsgBox "日期不能为空，请输入！", vbOKOnly + vbInformation, "提示"
txtFrmData(11).SetFocus
Exit Sub
End If
strSQL = "Select * from 基本情况 where 编号='" & Trim(txtFrmData(1).Text) & "'"
rst.Open strSQL, myDB, adOpenDynamic, adLockOptimistic
Debug.Print Val("")
If rst.EOF Then
'插入表
strSQL = ConstructInsertSQL(Me, "基本情况", "")
Debug.Print strSQL
myDB.Execute strSQL
MsgBox "保存成功！", vbOKOnly + vbInformation, "添加"
'Call ClearFrm(Me)
Else
'修改表
If MsgBox("编号已存在，是否更新原有编号的内容？ ", vbQuestion + vbYesNo, "提示") = vbYes Then
strSQL = ConstructUpdateSQL(Me, "基本情况", "", "编号")
Debug.Print strSQL
myDB.Execute strSQL
MsgBox "保存成功！", vbOKOnly + vbInformation, "修改"
End If
End If
cmdAdd.Enabled = True
Exit Sub
err:
MsgBox "错误:" & err.Description, vbInformation, "提示"
End Sub
Private Sub DTPicker1_Change()
txtFrmData(11).Text = DTPicker1.Value
End Sub
Private Sub Form_Resize()
Static iLeft1, iTop1, iLeft2
Static ifrmWidth, ifrmHeight
Debug.Print ifrmWidth, ifrmHeight
If Not (ifrmWidth = 0 Or ifrmHeight = 0) Then
Picture1.Left = iLeft1 + (Me.Width - ifrmWidth) / 2
Picture1.Top = iTop1 + (Me.Height - ifrmHeight) / 2
Picture2.Top = Picture1.Top + 6000
Picture2.Left = iLeft2 + (Me.Width - ifrmWidth) / 2
End If
iLeft1 = Picture1.Left
iTop1 = Picture1.Top
iLeft2 = Picture2.Left
ifrmWidth = Me.Width
ifrmHeight = Me.Height
End Sub
Private Sub txtFrmData_Change(Index As Integer)
Select Case Index
Case 8, 9, 10
txtFrmData(Index) = TextExam(txtFrmData(Index).Text, "1234567890.")
End Select
End Sub
Private Sub txtFrmData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
Dim strKey As String
Dim rst As ADODB.Recordset
On Error GoTo err
Set rst = New ADODB.Recordset
If KeyCode <> 13 Then
Exit Sub
End If
If Index = 1 Then
If Trim(txtFrmData(1).Text) <> "" Then
strKey = Trim(txtFrmData(1).Text)
'显示实例表
strSQL = "select * from 基本情况 where 编号='" & strKey & "'"
rst.Open strSQL, myDB, adOpenForwardOnly, adLockOptimistic
If Not rst.EOF Then
If MsgBox("编号重复,要修改原有的资料吗？", vbQuestion + vbYesNo, "提示") = vbYes Then
Call ShowDB(Me, strSQL)
Else
txtFrmData(1).Text = ""
txtFrmData(1).SetFocus
End If
Else
SendKeys "{tab}"
End If
Else
Call ClearFrm(Me)
End If
Else
SendKeys "{tab}"
End If
Exit Sub
err:
MsgBox err.Description, vbInformation, "提示"
End Sub
'Private Sub txtFrmData_LostFocus(Index As Integer)
' If Index = 8 Then
' Debug.Print Val(txtFrmData(4).Text)
' End If
'End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -