Access+VBA登录窗口及动态修改模块代码

xingyun86 2022-12-7 423

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)
只看楼主
全部楼主
返回