📄 vdmdi.frm
字号:
Const MSG22 = "删除查询定义吗？"
Const MSG23 = "删除字段吗？"
Const MSG24 = "删除索引吗？"
Const MSG25 = "删除表中所有记录吗？"
Const MSG26 = "删除的行："
Const MSG30 = "属性是只读的！"
'>>>>>>>>>>>>>>>>>>>>>>>>
Dim mHwnd As Long
Private Sub mnuBackup_Click()
frmBackup.Show vbModal
End Sub
Private Sub mnuDBImpExp_Click()
'导出表结构
Dim n As Integer
Dim Str As String
Dim cnn1 As New ADODB.Connection
Dim rstSchema As ADODB.Recordset
Dim rs As New ADODB.Recordset
Dim fldLoop As ADODB.Field
cnn1.Open gdbConString
Set rstSchema = cnn1.OpenSchema(adSchemaTables)
On Error GoTo nofile
filSelect.Filter = "HTML文件|*.html" '设置CommandDialog属性
filSelect.CancelError = True
filSelect.ShowSave
Open filSelect.FileName For Output As #1 '打开文件以输出
Print #1, "<html>" & vbCr
Print #1, "<head>" & vbCr
Print #1, "<meta http-equiv='Content-Type' content='text/html; charset=gb2312' />" & vbCr
Print #1, "<title>数据库表结构</title>" & vbCr
Print #1, "</head>" & vbCr
Do Until rstSchema.EOF
If rstSchema!TABLE_TYPE = "TABLE" Then
Str = "select top 1 * from [" & rstSchema!TABLE_NAME & "]"
rs.Open Str, cnn1, adOpenKeyset, adLockOptimistic
Print #1, "表名： " & rstSchema!TABLE_NAME & vbCr
Print #1, "<table width='800' border='1' cellpadding='0' cellspacing='0'>" & vbCr
Print #1, "<tr><td width='200'>字段名</td><td width='200'>字段类型</td><td width='200'>字段长度</td><td width='200'>可否为空</td></tr>" & vbCr
For n = 0 To rs.Fields.Count - 1
Print #1, "<tr><td width='200'>" & rs.Fields(n).Name & "</td>" & vbCr
Print #1, "<td width='200'>" & FieldType(rs.Fields(n).Type) & "</td>" & vbCr
Print #1, "<td width='200'>" & FieldSize(rs.Fields(n)) & "</td>" & vbCr
Print #1, "<td width='200'>" & FieldNULL(rs.Fields(n)) & "</td>" & vbCr
Print #1, "</tr>" & vbCr
Next
rs.Close
Print #1, "</table>" & "<br>"
End If
rstSchema.MoveNext
Loop
rstSchema.Close
cnn1.Close
Print #1, "</html>" & vbCr
Close #1
'nofile did nothing
nofile:
If Err.Number = 32755 Then
Else
End If
End Sub
Private Sub mnuDBOpen_Click()
Dim frm As New frmODBCLogon
frm.Show vbModal
If frm.DBOpened Then
ShowDBTools '显示表
RefreshTables Nothing
MsgBar MSG8, False
End If
Unload frm
Set frm = Nothing
End Sub
'打开表浏览窗口
Sub mnuDBPUOpen_Click()
On Error Resume Next
Dim frmTmp As Form
Dim i As Integer
gbFromSQL = False
Screen.MousePointer = vbHourglass
If gnodDBNode.Tag = TABLE_STR Then
Set frmTmp = New frmDataGrid
frmTmp.Height = frmMDI.Height - 2500
frmTmp.Width = frmMDI.Width - 1500
frmTmp.datDataCtl.ConnectionString = gdbConString
frmTmp.datDataCtl.RecordSource = "select * from " & StripConnect(gnodDBNode2.Text)
frmTmp.datDataCtl.Refresh
frmTmp.Fenye
frmTmp.Show
For i = 0 To frmTmp.datDataCtl.Recordset.Fields.Count - 1
frmTmp.Listzd.AddItem frmTmp.datDataCtl.Recordset.Fields.Item(i).Name
Next i
End If
Screen.MousePointer = vbDefault
MsgBar vbNullString, False
End Sub
Private Sub mnuHAbout_Click()
MsgBar MSG3, False
frmAboutBox.Show vbModal
MsgBar vbNullString, False
End Sub
Private Sub mnuDBClose_Click()
CloseCurrentDB
End Sub
Private Sub mnuDBErrors_Click()
On Error Resume Next
Screen.MousePointer = vbHourglass
RefreshErrors
Screen.MousePointer = vbDefault
If Err Then ShowError
End Sub
Private Sub mnuDBExit_Click()
Unload Me
End Sub
Private Sub mnuPLoginTimeout_Click()
On Error GoTo LTErr
Dim sNewValue As String
sNewValue = InputBox(MSG18, , CStr(glLoginTimeout))
If Len(sNewValue) = 0 Then Exit Sub
'试着设置新值
If Val(sNewValue) >= 0 Then
glLoginTimeout = Val(sNewValue)
DBEngine.LoginTimeout = glLoginTimeout
End If
Exit Sub
LTErr:
ShowError
End Sub
Private Sub mnuPOpenOnStartup_Click()
mnuPOpenOnStartup.Checked = Not mnuPOpenOnStartup.Checked
End Sub
Private Sub mnuPQueryTimeout_Click()
On Error GoTo QTErr
Dim sNewValue As String
If Not gbDBOpenFlag Then MsgBox MSG19, 48: Exit Sub
sNewValue = InputBox(MSG20)
If Len(sNewValue) = 0 Then Exit Sub
'试着设置新值
glQueryTimeout = Val(sNewValue)
Exit Sub
QTErr:
ShowError
'出错后重置窗体控件
End Sub
Private Sub mnuWArrange_Click()
Me.Arrange 3
End Sub
Private Sub mnuWCascade_Click()
Me.Arrange 0
End Sub
Private Sub mnuWTile_Click()
Me.Arrange 2
End Sub
Private Sub MDIForm_Load()
On Error GoTo MDILErr
Dim x As Integer
gnMULocking = True '缺省为权限锁定
'获得窗体座标
x = Val(GetRegistryString("WindowState", "2"))
If x = vbMaximized Then
Show
ElseIf x <> vbMinimized Then
frmMDI.WindowState = x
Else
frmMDI.WindowState = 0
End If
On Error GoTo MDILErr
'设置 DBEngine
DBEngine.IniPath = "HKEY_CURRENT_USER\Software\VB Program Settings\" & APP_CATEGORY & "\" & APPNAME
DBEngine.DefaultUser = "admin"
DBEngine.DefaultPassword = vbNullString
'登录到 Jet
On Error Resume Next
Set gwsMainWS = DBEngine.CreateWorkspace("MainWS", "admin", vbNullString)
If Err <> 0 Then
ShowError
Unload Me
Exit Sub
End If
stsStatusBar.Panels(2).Text = MSG15 & gwsMainWS.UserName & " "
On Error GoTo MDILErr
'添加工作空间到集合中，增加其数量
Workspaces.Append gwsMainWS
Me.Show
LoadRegistrySettings
Dim i As Integer
'如果选项已经在首选项菜单中设置，
'就试图打开上一次使用的数据库
If frmMDI.mnuPOpenOnStartup.Checked And Len(gsODBCServer) > 0 Then
mnuDBOpen_Click
Else
HideDBTools
End If
Exit Sub
MDILErr:
ShowError
End Sub
Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
ShutDownAll
End Sub
Private Sub mnuDBMRU_Click(Index As Integer)
On Error GoTo MRUErr
gsDBName = Mid(mnuDBMRU(Index).Caption, 4, Len(mnuDBMRU(Index).Caption))
gsDataType = mnuDBMRU(Index).Tag
'必须是一个 ODBC 数据库，因此需要加载 frmOpenDB
'这将获得连接部分
GetODBCConnectParts gsDataType
'调用将加载窗体的过程
mnuDBOpen_Click
Exit Sub
MRUErr:
ShowError
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -