Access+VBA登录窗口及动态修改模块代码
引用:microsoft ado ext. 2.8 for ddl and security(可选)
遍历所有的查询:
Dim obj As AccessObject, dbs As Object Set dbs = Application.CodeData ' Search for open AccessObject objects in AllQueries collection. For Each obj In dbs.AllQueries 'If obj.IsLoaded = True Then ' Print name of obj. Debug.Print obj.Name MsgBox obj.Name & obj.IsLoaded 'End If Next obj
登录按钮逻辑处理:用户名:李四/666666
Private Sub 登陆数据库_Click() Text0.SetFocus loginName = Text0.Text Text1.SetFocus loginPass = Text1.Value If loginName = "" Then MsgBox "请输入用户名!", vbOKOnly, "系统提示" Else If loginPass = "" Then MsgBox "请输入密码!", vbOKOnly, "系统提示" Else 'MsgBox ("[" + loginName + "][" + loginPass + "]") tpass = DLookup("[密码]", "用户表", "[用户名]='" + loginName + "'") If tpass <> "" Then If tpass <> loginPass Then MsgBox "密码错误,请重新输入!", vbOKOnly, "系统提示" Else MsgBox ("[" + loginName + "]登陆成功") strNewCode = "Sub Test ()" & vbLf & _ Space(4) & "Msgbox " & Chr(34) & "这是添加的代码!" & Chr(34) & vbLf & _ "End Sub" strNewCode = "Public Sub op()" & vbLf & _ Space(4) & "CommandBars(" & Chr(34) & "MyNewMenu223" & Chr(34) & ").Controls(" & Chr(34) & "工具" & Chr(34) & ").Controls.Add(Type:=msoControlButton, before:=1).Caption = " & Chr(34) & "表1" & vbLf & _ Space(4) & "DoCmd.OpenForm" & Space(2) & Chr(34) & "窗体C" & Chr(34) & ", acFormDS" & vbLf & _ Space(4) & "DoCmd.OpenQuery " & Chr(34) & "查询B" & vbLf & _ Space(4) & "DoCmd.OpenTable " & Chr(34) & "表A" & vbLf & _ "End Sub" strSql = "SELECT 菜单.操作,2 AS 序号 FROM 菜单 WHERE (((菜单.操作) Is Not Null)); UNION SELECT 菜单.新建菜单,1 AS 序号 FROM 菜单 WHERE (((菜单.新建菜单) Is Not Null));" Set rs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset) strNewCode = "Option Compare Database" & vbLf & "Public Sub op()" & vbLf For r = 1 To rs.RecordCount 'MsgBox CStr(rs.Fields("操作")) + "," + CStr(rs.Fields("序号")) strNewCode = strNewCode & Space(4) & CStr(rs.Fields("操作")) & vbLf rs.MoveNext Next strNewCode = strNewCode & "End Sub" linenum = VBE.ActiveVBProject.VBComponents("功能模块").CodeModule.CountOfLines VBE.ActiveVBProject.VBComponents("功能模块").CodeModule.DeleteLines 1, linenum VBE.ActiveVBProject.VBComponents("功能模块").CodeModule.AddFromString (strNewCode) DoCmd.Close acForm, "登陆窗体" End If Else MsgBox "密码错误,请重新输入!", vbOKOnly, "系统提示" End If End If End If End Sub
退出Access程序代码:
Private Sub 退出数据库_Click() 'MsgBox 123 'DoCmd.Close acForm, "登陆窗体" If (MsgBox("确认是否退出?", vbOKCancel)) = vbOK Then Application.Quit acQuitPrompt Else End If End Sub
其他遍历代码:
Dim objVBProject As Object Dim strReturn As String For Each objVBProject In Application.VBE.VBProjects If objVBProject.FileName = CurrentDb.Name Then strReturn = objVBProject.Name Exit For End If Next strsql = "SELECT 菜单.操作,2 AS 序号 FROM 菜单 WHERE (((菜单.操作) Is Not Null)); UNION SELECT 菜单.新建菜单,1 AS 序号 FROM 菜单 WHERE (((菜单.新建菜单) Is Not Null));" Set rs = CurrentDb.OpenRecordset(strsql, dbOpenDynaset) For Each fld In rs.Fields '遍历字段 'fldName = fld.Name '替换字段中的内容 'SQLstr = " update " & tblName & " set " & fldName & "= Replace(" & fldName & ",',','、');" 'MsgBox fld.Name 'DoCmd.SetWarnings False 'DoCmd.RunSQL SQLstr Next For r = 1 To rs.RecordCount 'GetVal = GetVal & rs(FieldName) & ";" MsgBox CStr(rs.Fields("操作")) + "," + CStr(rs.Fields("序号")) rs.MoveNext Next Dim rs As New ADODB.Recordset Dim r As Long rs.Open strsql, Application.CurrentProject.Connection, adOpenKeyset, adLockOptimistic For r = 1 To rs.RecordCount 'GetVal = GetVal & rs(FieldName) & ";" 'MsgBox rs("操作") + "," + rs("序号") rs.MoveNext Next On Error Resume Next Dim db As Database Dim tblName As String Dim fldName As String Dim SQLstr As String Dim i As Integer Set db = DBEngine.Workspaces(0).Databases(0) db.TableDefs.Refresh For i = 0 To db.TableDefs.Count - 1 tblName = db.TableDefs(i).Name '遍历表 'MsgBox tblName If Mid(tblName, 1, 4) <> "MSYS" And tblName = "查询1" Then '避开系统表(以'MSYS'开头) Set rst = CurrentDb.OpenRecordset(tblName, dbOpenDynaset) For Each fld In rst.Fields '遍历字段 fldName = fld.Name '替换字段中的内容 'SQLstr = " update " & tblName & " set " & fldName & "= Replace(" & fldName & ",',','、');" 'MsgBox fldName 'DoCmd.SetWarnings False 'DoCmd.RunSQL SQLstr Next End If Next
遍历获取查询的数据:
Dim qdf As DAO.QueryDef Set qdfs = CurrentDb.QueryDefs For Each qdf In qdfs MsgBox qdf.Name Set rs1 = qdf.OpenRecordset(dbOpenDynaset) strNewCode = "Option Compare Database" & vbLf & "Public Sub op()" & vbLf For r = 1 To rs1.RecordCount strNewCode = strNewCode & Space(4) & CStr(rs1.Fields("操作")) & vbLf rs1.MoveNext Next strNewCode = strNewCode & "End Sub" MsgBox strNewCode 'If InStr(qdf.Name, "2") <> 0 Then 'If query name contains 2 'DoCmd.OutputTo acOutputQuery, qdf.Name, acFormatXLSX, "C:\test\" & qdf.Name & ".xlsx", False 'End If Next qdf Set qdf = Nothing
数组排序:
Function BubbleSort(TempArray1 As Variant, TempArray As Variant) Dim Temp As Variant Dim Temp1 As Variant Dim i As Integer Dim NoExchanges As Integer ' Loop until no more "exchanges" are made. Do NoExchanges = True ' Loop through each element in the array. For i = 1 To UBound(TempArray) - 1 ' If the element is greater than the element ' following it, exchange the two elements. If TempArray(i) > TempArray(i + 1) Then NoExchanges = False Temp = TempArray(i) TempArray(i) = TempArray(i + 1) TempArray(i + 1) = Temp Temp1 = TempArray1(i) TempArray1(i) = TempArray1(i + 1) TempArray1(i + 1) = Temp1 End If Next i Loop While Not (NoExchanges) End Function
带有排序的登陆写入代码模块:
Private Sub 登陆数据库_Click() Dim loginName$ loginName = "" Text0.SetFocus loginName = Text0.Text Text1.SetFocus loginPass = Text1.Value If loginName = "" Then MsgBox "请输入用户名!", vbOKOnly, "温馨提示:" Text0.SetFocus Else If loginPass = "" Or IsNull(loginPass) Then MsgBox "请输入密码!", vbOKOnly, "温馨提示:" Text1.SetFocus Else tpass = DLookup("[密码]", "用户表", "[用户名]='" + loginName + "'") If tpass <> "" And IsNull(tpass) = False Then If tpass <> loginPass Then MsgBox "密码错误,请重新输入!", vbOKOnly, "温馨提示:" Text1.SetFocus Else ' MsgBox ("[ " + loginName + " ] 帐户 登陆成功"), vbOKOnly, "温馨提示:" ' strNewCode = "Sub Test ()" & vbLf & _ ' Space(4) & "Msgbox " & Chr(34) & "这是添加的代码!" & Chr(34) & vbLf & _ ' "End Sub" ' strNewCode = "Public Sub op()" & vbLf & _ ' Space(4) & "CommandBars(" & Chr(34) & "MyNewMenu223" & Chr(34) & ").Controls(" & Chr(34) & "工具" & Chr(34) & ").Controls.Add(Type:=msoControlButton, before:=1).Caption = " & Chr(34) & "表1" & vbLf & _ ' Space(4) & "DoCmd.OpenForm" & Space(2) & Chr(34) & "窗体C" & Chr(34) & ", acFormDS" & vbLf & _ ' Space(4) & "DoCmd.OpenQuery " & Chr(34) & "查询B" & vbLf & _ ' Space(4) & "DoCmd.OpenTable " & Chr(34) & "表A" & vbLf & _ ' "End Sub" strSql = "SELECT 菜单.操作,2 AS 序号 FROM 菜单 WHERE (((菜单.操作) Is Not Null)); UNION SELECT 菜单.新建菜单,1 AS 序号 FROM 菜单 WHERE (((菜单.新建菜单) Is Not Null));" Set rs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset) strNewCode = "Option Compare Database" & vbLf & "Public Sub op()" & vbLf Dim myStringArray() As String Dim myStringArrayI() As Integer ReDim myStringArray(rs.RecordCount) ReDim myStringArrayI(rs.RecordCount) For r = 1 To rs.RecordCount myStringArray(r) = Space(4) & CStr(rs.Fields("操作")) & vbLf myStringArrayI(r) = rs.Fields("序号") rs.MoveNext Next BubbleSort myStringArray, myStringArrayI For r = 1 To rs.RecordCount strNewCode = strNewCode & myStringArray(r) Next r strNewCode = strNewCode & "End Sub" linenum = VBE.ActiveVBProject.VBComponents("功能模块").CodeModule.CountOfLines VBE.ActiveVBProject.VBComponents("功能模块").CodeModule.DeleteLines 1, linenum VBE.ActiveVBProject.VBComponents("功能模块").CodeModule.AddFromString (strNewCode) DoCmd.Close acForm, "登陆窗体" End If Else MsgBox "用户名错误,请重新输入!", vbOKOnly, "温馨提示:" Text0.SetFocus End If End If End If End Sub
执行保存命令,不提示:
DoCmd.SetWarnings False DoCmd.RunCommand acCmdSaveRecord DoCmd.SetWarnings True
常见错误及解决方案:
1.加载 DLL 时出错(错误 48):亲测,重装office。原因猜测可能是手动执行了重新注册ado的步骤导致。
收藏的用户(0)
X
正在加载信息~
2
最新回复 (0)