PDA

View Full Version : Prompted for Visual Basic password when closing Excel



cssamerican
09-14-2006, 07:07 AM
I have already looked at this link http://www.vbaexpress.com/forum/showthread.php?t=5770 and I can't find the same mistake in my code. Doesn't mean it isn't there, but I have been looking for quite some time, so I believe my problem is different.

I keep geeting a prompt to enter the Visual Basic password whenever I close Excel after my workbook has been opened. The thing is I never got this when I first created it in Excel 98. However, I am now running Excel 2003 and it comes up every time.

Option Explicit
Option Private Module
Sub DAO_Report_Engine()
Const stExtens As String = "Excel 8.0;HDR=Yes;IMEX=1"

'Variables for DAO.
Dim DAO_ws As DAO.Workspace
Dim DAO_db As DAO.Database
Dim DAO_rs As DAO.Recordset
Dim strDb As String
Dim strSQLSummary As String
Dim strSQLDetail As String
strSQLSummary = "SELECT [Department_Data$].Department, " & vbNewLine & _
"[Department_Data$].Department_Head, " & vbNewLine & _
"[Department_Data$].Department_Code, " & vbNewLine & _
"SUM([User_Data$].Centralized), " & vbNewLine & _
"SUM([User_Data$].Paper), " & vbNewLine & _
"SUM([User_Data$].IDCard), " & vbNewLine & _
"SUM([User_Data$].Print_Management), " & vbNewLine & _
"SUM([User_Data$].Local+[User_Data$].Network) AS 'NCPrints', " & vbNewLine & _
"SUM([User_Data$].Xerox) AS 'CPrints', " & vbNewLine & _
"SUM(PD9001847+NYD001310+NYD001003+EYF021352+KLD000876+" _
& "KLD000875+NYD001313+MRN020150+MRN016162+EYF021355+MRN016174+" _
& "KLD000878+EYF020925+NYD001307+PDE132246+KLD001037+MYP105401) " _
& "AS 'CCopies' " & vbNewLine & _
"FROM [User_Data$] " & vbNewLine & _
"INNER JOIN ([Department_Data$]" & vbNewLine & _
"LEFT JOIN [Password_Data$]" & vbNewLine & _
"ON [Department_Data$].User_Name=[Password_Data$].User_Name) " & vbNewLine & _
"ON [User_Data$].Budget_Code=[Department_Data$].Department_Code " & vbNewLine & _
"WHERE [Password_Data$].Password = '" & LogInForm.tbPassword.Value & "' " & vbNewLine & _
"GROUP BY Department, Department_Head, Department_Code " & vbNewLine & _
"ORDER BY Department_Code"
strSQLDetail = "SELECT Last_Name, " & vbNewLine & _
"First_Name, " & vbNewLine & _
"Budget_Code, " & vbNewLine & _
"SUM(Centralized), " & vbNewLine & _
"SUM(Paper), " & vbNewLine & _
"SUM(IDCard), " & vbNewLine & _
"SUM(Print_Management), " & vbNewLine & _
"SUM(Local+Network) AS 'NCPrints', " & vbNewLine & _
"SUM(Xerox) AS 'CPrints', " & vbNewLine & _
"SUM(PD9001847+NYD001310+NYD001003+EYF021352+KLD000876+" _
& "KLD000875+NYD001313+MRN020150+MRN016162+EYF021355+MRN016174+" _
& "KLD000878+EYF020925+NYD001307+PDE132246+KLD001037+MYP105401) " _
& "AS 'CCopies' " & vbNewLine & _
"FROM [User_Data$] " & vbNewLine & _
"WHERE Budget_Code = '" & ReportForm.cbBudget_Code.Value & "' " & vbNewLine & _
"GROUP BY Last_Name, First_Name, Budget_Code"
'Variables for Excel.
Dim wbBook As Workbook
Dim wsrTarget As Worksheet
Dim rnTarget As Range
Dim Switch As Boolean
Dim rwIndex As Integer
Dim colIndex As Integer

Application.ScreenUpdating = False

Set wbBook = ActiveWorkbook
Set wsrTarget = wbBook.Worksheets("Reports")
With wsrTarget
.Cells.ClearContents
.Range("D6").Value = "Centralized"
.Range("D7").Value = "Production"
.Range("E7").Value = "Paper"
.Range("F7").Value = "ID Card"
.Range("G6").Value = "Print"
.Range("G7").Value = "Management"
.Range("H6").Value = "Non-Xerox Prints"
.Range("H7").Value = "Rate is at .0056?"
.Range("I6").Value = "Xerox Prints"
.Range("I7").Value = "Rate is at 8?"
.Range("J6").Value = "Xerox Copies"
.Range("J7").Value = "Rate is at 8?"
.Range("K6").Value = "Cost of Impressions"
.Range("K7").Value = "At Current Rates"
Set rnTarget = .Range("A8")
End With
strDb = wbBook.FullName
Switch = False
rwIndex = 8
colIndex = 3

'Instantiate the DAO objects.
Set DAO_ws = DBEngine.Workspaces(0)
Set DAO_db = DAO_ws.OpenDatabase(strDb, False, True, stExtens)
Select Case ReportForm.strReport
Case "Detail"
Set DAO_rs = DAO_db.OpenRecordset(strSQLDetail, dbOpenForwardOnly)
With wsrTarget
.Range("A7").Value = "Last Name"
.Range("B7").Value = "First Name"
.Range("C7").Value = "Budget Code"
End With
Case "Summary"
Set DAO_rs = DAO_db.OpenRecordset(strSQLSummary, dbOpenForwardOnly)
With wsrTarget
.Range("A7").Value = "Department"
.Range("B7").Value = "Department Head"
.Range("C7").Value = "Budget Code"
End With
Case Else
MsgBox "No reports selected.", vbCritical
Exit Sub
End Select

'Write the Recordset to the target range.
rnTarget.CopyFromRecordset DAO_rs

'Close the instances.
DAO_rs.Close
DAO_db.Close
DAO_ws.Close

'Release objects from memory.
Set DAO_rs = Nothing
Set DAO_db = Nothing
Set DAO_ws = Nothing

'Run total routine
Do While Switch = False
If wsrTarget.Cells(rwIndex, colIndex) <> Empty Then
wsrTarget.Cells(rwIndex, 11).FormulaR1C1 = "=(RC[-3]*0.0056)+(SUM(RC[-2]:RC[-1])*0.08)"
rwIndex = rwIndex + 1
Else
wsrTarget.Cells(rwIndex, 1).Value = "SubTotal"
wsrTarget.Cells(rwIndex, 4).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 5).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 6).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 7).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 8).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 9).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 10).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
wsrTarget.Cells(rwIndex, 11).FormulaR1C1 = "=SUM(R[-" & (rwIndex - 8) & "]C:R[-1]C)"
rwIndex = rwIndex + 1
wsrTarget.Cells(rwIndex, 1).Value = "GrandTotal"
wsrTarget.Cells(rwIndex, 11).FormulaR1C1 = "=SUM(R[-1]C[-7],R[-1]C[-6],R[-1]C[-5],R[-1]C[-4],R[-1]C)"
Switch = True
End If
Loop
Application.ScreenUpdating = True
End Sub

Sub DAO_Password_Engine()
Const stExtens As String = "Excel 8.0;HDR=Yes;IMEX=1"

'Variables for DAO.
Dim DAO_ws As DAO.Workspace
Dim DAO_db As DAO.Database
Dim DAO_rs As DAO.Recordset
Dim strDb As String
Dim strSQL As String
strSQL = "SELECT DISTINCT [Department_Data$].Department_Code " & vbNewLine & _
"FROM [User_Data$] " & vbNewLine & _
"INNER JOIN ([Department_Data$]" & vbNewLine & _
"LEFT JOIN [Password_Data$]" & vbNewLine & _
"ON [Department_Data$].User_Name=[Password_Data$].User_Name) " & vbNewLine & _
"ON [User_Data$].Budget_Code=[Department_Data$].Department_Code " & vbNewLine & _
"WHERE [Password_Data$].Password='" & LogInForm.tbPassword.Value & "' "
'Variables for Excel.
Dim wbBook As Workbook
Dim rsArray As Variant
Dim rsCount As Integer
Dim Row As Integer
Dim wsudTarget As Worksheet
Dim wsddTarget As Worksheet
Dim wspdTarget As Worksheet
Dim wsrTarget As Worksheet
Set wbBook = ActiveWorkbook
Set wsudTarget = wbBook.Worksheets("User_Data")
Set wsddTarget = wbBook.Worksheets("Department_Data")
Set wspdTarget = wbBook.Worksheets("Password_Data")
Set wsrTarget = wbBook.Worksheets("Reports")
strDb = wbBook.FullName

'Instantiate the DAO objects.
Set DAO_ws = DBEngine.Workspaces(0)
Set DAO_db = DAO_ws.OpenDatabase(strDb, False, True, stExtens)
Set DAO_rs = DAO_db.OpenRecordset(strSQL, dbOpenSnapshot)

'Checks to make sure a valid password was used.
If DAO_rs.BOF = True And DAO_rs.EOF = True Then
MsgBox "Password invalid.", vbCritical
Exit Sub
End If

'Write the Recordset to the ComboBox.
With DAO_rs
.MoveLast
.MoveFirst
rsArray = .GetRows(.RecordCount)
rsCount = .RecordCount
End With
ReportForm.cbBudget_Code.Clear
ReportForm.cbBudget_Code.Column() = rsArray

'Close the instances.
DAO_rs.Close
DAO_db.Close
DAO_ws.Close

'Release objects from memory.
Set DAO_rs = Nothing
Set DAO_db = Nothing
Set DAO_ws = Nothing

'Setting sheets visibility.
Application.ScreenUpdating = False
Select Case Pass(LogInForm.tbPassword.Value)
Case "Administrator"
wsudTarget.Visible = xlSheetVisible
wsddTarget.Visible = xlSheetVisible
wspdTarget.Visible = xlSheetVisible
wsrTarget.Visible = xlSheetVisible
Worksheets("Reports").LaunchApp.Visible = True
Worksheets(5).Visible = xlSheetVisible
Worksheets(6).Visible = xlSheetVisible
Worksheets("Billable_Supplies").Visible = xlSheetVisible
Worksheets("Account_Balance").Visible = xlSheetVisible
Case "Accounting"
wspdTarget.Visible = xlSheetVisible
wsrTarget.Visible = xlSheetVisible
Worksheets("Reports").LaunchApp.Visible = True
Worksheets(5).Visible = xlSheetVisible
Worksheets(6).Visible = xlSheetVisible
Worksheets("Billable_Supplies").Visible = xlSheetVisible
Worksheets("Account_Balance").Visible = xlSheetVisible
Case Else
wsrTarget.Visible = xlSheetVisible
Worksheets("Reports").LaunchApp.Visible = True
End Select
Application.ScreenUpdating = True
End Sub
Function Pass(strPassword)
'Variables for Excel.
Dim wbBook As Workbook
Dim wspdTarget As Worksheet
Dim Switch As Boolean
Dim rwIndex As Integer
Set wbBook = ActiveWorkbook
Set wspdTarget = wbBook.Worksheets("Password_Data")
Switch = False
rwIndex = 1

'Converts password to the username assosiated with it.
Do While Switch = False
If wspdTarget.Cells(rwIndex, 1) <> Empty And strPassword <> wspdTarget.Cells(rwIndex, 2) Then
rwIndex = rwIndex + 1
ElseIf wspdTarget.Cells(rwIndex, 1) <> Empty And strPassword = wspdTarget.Cells(rwIndex, 2) Then
Pass = wspdTarget.Cells(rwIndex, 1)
Switch = True
End If
Loop
End Function
Sub Data_Fill()
Dim wbBook As Workbook
Dim wsudTarget As Worksheet

Set wbBook = ActiveWorkbook
Set wsudTarget = wbBook.Worksheets("User_Data")
Application.ScreenUpdating = False
wsudTarget.Cells.SpecialCells(xlCellTypeBlanks).Value = 0
Application.ScreenUpdating = True
End Sub


I rather not post the file because it has a lot of private data, and would take forever to remove it all. However, if that is the only way my problem can be solved then I guess I could repost this problem in a couple of weeks with the actual file if need be.