I have a created a database that has the AllowBypassKey shift key disabled. What I am trying to do is have a hidden box that when double clicked on pops up a box where the user must enter the password and then the AllowBypassKey is enabled. I have added the code I have written so far but I am getting a "Sub or Function not defined" for the SetProperties portion. I have shown the disable AllowBypassKey code as well.
Disable Bypass code:
Function ap_DisableShift()
On Error GoTo errDisableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
db.Properties("AllowByPassKey") = False
Exit Function
errDisableShift:
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, False)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Double-Click Code (Error popping up!)
Private Sub Secret_DblClick(Cancel As Integer)
On Error GoTo Err_bDisableBypassKey_Click
Dim strInput As String
Dim strMsg As String
Beep
strMsg = "Do you want to enable the Bypass Key"
strInput = InputBox(Prompt:=strMsg, Title:="Disable Bypass Key Password")
If strInput = "PASSWORD" Then
SetProperties "AllowBypassKey", dbBoolean, True
Beep
MsgBox "The Bypass Key has been enabled."
Else
Beep
SetProperties "AllowBypassKey", dbBoolean, False
MsgBox "Incorrect ''AllowBypassKey'' Password!"
Exit Sub
End If
Exit_bDisableBypassKey_Click:
Exit Sub
Err_bDisableBypassKey_Click:
MsgBox "bDisableBypassKey_Click", Err.Number, Err.Description
Resume Exit_bDisableBypassKey_Click
End Sub
You can use Allen Browne's SetPropertyDAO and HasProperty functions to manage the AllowBypassKey setting. (Source for those functions is here; and also included at the bottom of this answer.)
Then to normally disable AllowBypassKey for all users at database start, create this function and call it from the RunCode action of your database's AutoExec macro:
Public Function StartUp()
SetPropertyDAO CurrentDb, "AllowBypassKey", dbBoolean, False
End Function
To allow your privileged user(s) to override that setting (IOW to enable AllowBypassKey), use this tested version of your Secret_DblClick procedure:
Private Sub Secret_DblClick(Cancel As Integer)
Dim strInput As String
Dim strMsg As String
On Error GoTo Err_bDisableBypassKey_Click
Beep
strMsg = "Do you want to enable the Bypass Key"
strInput = InputBox(Prompt:=strMsg, Title:="Disable Bypass Key Password")
If strInput = "PASSWORD" Then
SetPropertyDAO CurrentDb, "AllowBypassKey", dbBoolean, True
Beep
MsgBox "The Bypass Key has been enabled."
Else
Beep
SetPropertyDAO CurrentDb, "AllowBypassKey", dbBoolean, False
MsgBox "Incorrect 'AllowBypassKey' Password!"
End If
Exit_bDisableBypassKey_Click:
Exit Sub
Err_bDisableBypassKey_Click:
MsgBox "bDisableBypassKey_Click", Err.Number, Err.Description
Resume Exit_bDisableBypassKey_Click
End Sub
Function SetPropertyDAO(obj As Object, strPropertyName As String, intType As Integer, _
varValue As Variant, Optional strErrMsg As String) As Boolean
On Error GoTo ErrHandler
'Purpose: Set a property for an object, creating if necessary.
'Arguments: obj = the object whose property should be set.
' strPropertyName = the name of the property to set.
' intType = the type of property (needed for creating)
' varValue = the value to set this property to.
' strErrMsg = string to append any error message to.
If HasProperty(obj, strPropertyName) Then
obj.Properties(strPropertyName) = varValue
Else
obj.Properties.Append obj.CreateProperty(strPropertyName, intType, varValue)
End If
SetPropertyDAO = True
ExitHandler:
Exit Function
ErrHandler:
strErrMsg = strErrMsg & obj.Name & "." & strPropertyName & " not set to " & _
varValue & ". Error " & Err.Number & " - " & Err.Description & vbCrLf
Resume ExitHandler
End Function
Public Function HasProperty(obj As Object, strPropName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant
On Error Resume Next
varDummy = obj.Properties(strPropName)
HasProperty = (Err.Number = 0)
End Function
I am investigating some software written by a programmer before I came on-board at the company I work for.
They have some VBA code (in MS Access) that copies some files, writes to tables, etc., and somewhere in this process it is hanging up. It doesn't return any error codes or messages (in the error handler or in any other way). It just hangs up and Access goes into the "Not Responding" mode until it is forcibly stopped.
Here is the VBA code which handles the "Export" button (which is where it hangs):
Public Sub cmd_export_Click()
Dim ws As New WshShell, clsF As New clsNewFile, aspChemInv As MyCstmFile, _
fso As New IWshRuntimeLibrary.FileSystemObject, strFileName As String, _
fld As IWshRuntimeLibrary.Folder, fi As File
strFileName = Split(Field0.Value, ",")(0) & "_cheminv"
On Error GoTo Err_handler
Dim TblDeltree As String
Dim strArrTmpName
strArrTmpName = Split(Forms![MAIN MENU]![Field0], ", ")
TableName = strArrTmpName(0) & ", " & strArrTmpName(1)
If IsNull(Forms![MAIN MENU]![Field0]) = False Then
i = 0
Digits = Left(TableName, InStr(1, TableName, ",") - 1)
ShtDigits = Left(Digits, 2)
DoCmd.TransferDatabase acExport, "Microsoft Access", _
"\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
"\client.mdb", acTable, Forms![MAIN MENU]![Field0], TableName
'Scott request change (see email To: Ros Vicente Wed 4/16/2014 9:26 AM)
'Data Calculations
'TIER II CANDIDATES
'Revert changes per verbal (Scott Vaughn) 5/6/2014 10:09 AM
DoCmd.TransferDatabase acExport, "Microsoft Access", _
"\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
"\client.mdb", acTable, "Data Calculations", "Data Calculations"
DoCmd.TransferDatabase acExport, "Microsoft Access", _
"\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
"\client.mdb", acTable, "TIER II CANDIDATES", "TIER II CANDIDATES"
DoCmd.OpenReport "TIER II CANDIDATES", acViewPreview
Set rpt = Application.Reports![TIER II CANDIDATES]
Dim strReportsPath As String
strReportsPath = "\\A02-DS1\Public\Clients\" & ShtDigits & "\" & Digits & "\"
'ScreenShot rpt
DoCmd.OutputTo acOutputReport, Report, acFormatSNP, strReportsPath & rpt.Name & ".SNP", 0
DoCmd.Close acReport, rpt.Name
'DoCmd.OpenReport "Product Quantity List", acViewPreview
'Set rpt = Application.Reports![Product Quantity List]
modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"
Else
MsgBox "Please select the client table below.", vbExclamation, "Status: Export"
End If
If Not fso.FolderExists("C:\Temp") Then fso.CreateFolder ("C:\Temp")
ws.CurrentDirectory = "C:\Temp"
If Not fso.FolderExists(ws.CurrentDirectory & "\ESD_Upload") Then fso.CreateFolder ws.CurrentDirectory & "\ESD_Upload"
ws.CurrentDirectory = ws.CurrentDirectory & "\ESD_Upload"
Dim xFile As MyCstmFile
Set fld = fso.GetFolder("\\a02-ds1\Env-Sci\AutoCAD Files\Publish")
Dim strCurrentFile As String
For Each fi In fld.Files
strCurrentFile = fi.Name
fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile
Next
Dim tmpMSDS As New clsChemicalInventory
fso.CopyFile "\\a02-ds1\applicationDatabase$\MSDS.mdb", ws.CurrentDirectory & "\" & fGetUserName _
& ".mdb", True
tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"
Set fld = fso.GetFolder(ws.CurrentDirectory)
For Each fi In fld.Files
If InStr(1, fi.Name, ".txt") = 0 And InStr(1, fi.Name, ".mdb") = 0 Then _
fso.CopyFile fi.Name, "\\a02-ds1\Vanguard Website\OHMMP\Clients\", True
If InStr(1, fi.Name, "layout.pdf") <> 0 Then _
fso.CopyFile fi.Name, "\\A02-DS1\public\Clients\Layouts\", True: _
fso.CopyFile fi.Name, "\\A01-DC1\clients$\", True
If InStr(1, fi.Name, "_msds_") <> 0 Then _
fso.CopyFile fi.Name, "\\A01-DC1\clients$\", True
Next
ws.CurrentDirectory = "C:\Temp"
fso.DeleteFolder ws.CurrentDirectory & "\ESD_Upload"
Set fso = Nothing
Set fld = Nothing
Set ws = Nothing
MsgBox "Export Completed"
Exit_Handler:
Exit Sub
Err_handler:
If Err.Number = 70 Then
MsgBox "File " & strCurrentFile & " is Open.", vbOKOnly, "Open File"
Else
MsgBox "An Error as occured while trying to complete this task." _
& vbCrLf & "Please report the following error to your IT department: " _
& vbCrLf & Err.Number & ":" & vbCrLf & Err.Description, vbCritical, "Error"
End If
'Resume
Resume Exit_Handler
End Sub
Unfortunately I haven't had too much experience with VB (I've used mostly SQL in the past) and while I've been researching the functions, and all, I can't seem to find a way to figure out where or why this is hanging up in the way that it is.
Is there any way to tell what's going on here or, perhaps, where I should look or what I can do to find out?
Edit
Also, I am using Adobe Acrobat 9.0.0 (just freshly installed from DVD).
New Things Found
I've realized there are 3 separate issues going on here, but not sure yet how to fix them.
1) I get an Error 58 (File already exists on the following line:
fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile
This is completely understandable since the MoveFile function in VB doesn't support the overwriting of files. Not sure who wrote that, but they overlooked a major flaw there. I plan on using CopyFile and then deleting the source when done to solve this one, so no problems here.
2) I am getting an error 3043 (Disk or Network Error) on the following line (which #Time Williams asked about in the comments below [I'm still investigating what's going on there, but I don't know where to find the location of self-built global functions]):
tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"
3) And THIS is where the program hangs:
modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"
This is still a complete puzzle to me, because I've never used any method like this before, in any language.
Even More Stuff Found
modPDFCreator:
' The function to call is RunReportAsPDF
'
' It requires 2 parameters: the Access Report to run
' the PDF file name
'
' Enjoy!
'
' Eric Provencher
'===========================================================
Option Compare Database
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (dest As Any, _
source As Any, _
ByVal numBytes As Long)
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
Alias "RegCreateKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal Reserved As Long, _
ByVal lpClass As String, _
ByVal dwOptions As Long, _
ByVal samDesired As Long, _
ByVal lpSecurityAttributes As Long, _
phkResult As Long, _
lpdwDisposition As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function apiFindExecutable Lib "shell32.dll" _
Alias "FindExecutableA" (ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Const KEY_READ = &H20019 ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
' SYNCHRONIZE))
Const KEY_WRITE = &H20006 '((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or
' KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Function RunReportAsPDF(prmRptName As String, _
prmPdfName As String) As Boolean
' Returns TRUE if a PDF file has been created
Dim AdobeDevice As String
Dim strDefaultPrinter As String
'Find the Acrobat PDF device
AdobeDevice = GetRegistryValue(HKEY_CURRENT_USER, _
"Software\Microsoft\WIndows NT\CurrentVersion\Devices", _
"Adobe PDF")
If AdobeDevice = "" Then ' The device was not found
MsgBox "You must install Acrobat Writer before using this feature"
RunReportAsPDF = False
Exit Function
End If
' get current default printer.
strDefaultPrinter = Application.Printer.DeviceName
Set Application.Printer = Application.Printers("Adobe PDF")
'Create the Registry Key where Acrobat looks for a file name
CreateNewRegistryKey HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl"
'Put the output filename where Acrobat could find it
'SetRegistryValue HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl", _
Find_Exe_Name(CurrentDb.Name, CurrentDb.Name), _
prmPdfName
Dim oShell As Object
Dim strRegKey As String
Set oShell = CreateObject("WScript.Shell")
On Error GoTo ErrorHandler
' strRegKey = oShell.RegRead("HKEY_CURRENT_USER\Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder\1")
' If Err.Number = -2147024893 Then
' ' Code for if the key doesn't exist
' MsgBox "The key does not exist"
' Else
' ' Code for if the key does exist
' MsgBox "The key exists"
' End If
Dim strRegPath As String
strRegPath = "Software\Adobe\Acrobat Distiller\9.0\AdobePDFOutputFolder"
1:
SetRegistryValue HKEY_CURRENT_USER, strRegPath, "2", Left(prmPdfName, InStrRev(prmPdfName, "\") - 1)
ErrorHandler:
If Err.Number <> 0 Then strRegPath = "Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder": Err.Clear: Resume 1
On Error GoTo Err_handler
Dim strReportName As String
strReportName = Left(Right(prmPdfName, Len(prmPdfName) - InStrRev(prmPdfName, "\")), _
Len(Right(prmPdfName, Len(prmPdfName) - InStrRev(prmPdfName, "\"))) - 4)
DoCmd.CopyObject , strReportName, acReport, prmRptName
DoCmd.OpenReport strReportName, acViewNormal 'Run the report
DoCmd.DeleteObject acReport, strReportName
' While Len(Dir(prmPdfName)) = 0 ' Wait for the PDF to actually exist
' DoEvents
' Wend
RunReportAsPDF = True ' Mission accomplished!
Normal_Exit:
Set Application.Printer = Application.Printers(strDefaultPrinter) ' Restore default printer
On Error GoTo 0
Exit Function
Err_handler:
If Err.Number = 2501 Then ' The report did not run properly (ex NO DATA)
RunReportAsPDF = False
Resume Normal_Exit
Else
RunReportAsPDF = False ' The report did not run properly (anything else!)
MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description
Resume Normal_Exit
End If
End Function
Public Function Find_Exe_Name(prmFile As String, _
prmDir As String) As String
Dim Return_Code As Long
Dim Return_Value As String
Return_Value = Space(260)
Return_Code = apiFindExecutable(prmFile, prmDir, Return_Value)
If Return_Code > 32 Then
Find_Exe_Name = Return_Value
Else
Find_Exe_Name = "Error: File Not Found"
End If
End Function
Public Sub CreateNewRegistryKey(prmPredefKey As Long, _
prmNewKey As String)
' Example #1: CreateNewRegistryKey HKEY_CURRENT_USER, "TestKey"
'
' Create a key called TestKey immediately under HKEY_CURRENT_USER.
'
' Example #2: CreateNewRegistryKey HKEY_LOCAL_MACHINE, "TestKey\SubKey1\SubKey2"
'
' Creates three-nested keys beginning with TestKey immediately under
' HKEY_LOCAL_MACHINE, SubKey1 subordinate to TestKey, and SubKey3 under SubKey2.
'
Dim hNewKey As Long 'handle to the new key
Dim lRetVal As Long 'result of the RegCreateKeyEx function
lRetVal = RegOpenKeyEx(prmPredefKey, prmNewKey, 0, KEY_ALL_ACCESS, hKey)
If lRetVal <> 5 Then
lRetVal = RegCreateKeyEx(prmPredefKey, prmNewKey, 0&, _
vbNullString, REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
End If
RegCloseKey (hNewKey)
End Sub
Function GetRegistryValue(ByVal hKey As Long, _
ByVal KeyName As String, _
ByVal ValueName As String, _
Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
' Read a Registry value
'
' Use KeyName = "" for the default value
' If the value isn't there, it returns the DefaultValue
' argument, or Empty if the argument has been omitted
'
' Supports DWORD, REG_SZ, REG_EXPAND_SZ, REG_BINARY and REG_MULTI_SZ
' REG_MULTI_SZ values are returned as a null-delimited stream of strings
' (VB6 users can use SPlit to convert to an array of string)
' Prepare the default result
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
' Open the key, exit if not found.
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
Exit Function
End If
' prepare a 1K receiving resBinary
length = 1024
ReDim resBinary(0 To length - 1) As Byte
' read the registry key
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
' if resBinary was too small, try again
If retVal = ERROR_MORE_DATA Then
' enlarge the resBinary, and read the value again
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
' return a value corresponding to the value type
Select Case valueType
Case REG_DWORD
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_SZ, REG_EXPAND_SZ
' copy everything but the trailing null char
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
GetRegistryValue = resString
Case REG_BINARY
' resize the result resBinary
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
Case REG_MULTI_SZ
' copy everything but the 2 trailing null chars
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else
GetRegistryValue = ""
' RegCloseKey handle
' Err.Raise 1001, , "Unsupported value type"
End Select
RegCloseKey handle ' close the registry key
End Function
Function SetRegistryValue(ByVal hKey As Long, _
ByVal KeyName As String, _
ByVal ValueName As String, _
Value As Variant) As Boolean
' Write or Create a Registry value
' returns True if successful
'
' Use KeyName = "" for the default value
'
' Value can be an integer value (REG_DWORD), a string (REG_SZ)
' or an array of binary (REG_BINARY). Raises an error otherwise.
Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim byteValue As Byte
Dim length As Long
Dim retVal As Long
' Open the key, exit if not found
If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
Err.Raise 1
Exit Function
End If
' three cases, according to the data type in Value
Select Case VarType(Value)
Case vbInteger, vbLong
lngValue = Value
retVal = RegSetValueEx(handle, ValueName, 0, REG_DWORD, lngValue, 4)
Case vbString
strValue = Value
retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, Len(strValue))
Case vbArray
binValue = Value
length = UBound(binValue) - LBound(binValue) + 1
retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, binValue(LBound(binValue)), length)
Case vbByte
byteValue = Value
length = 1
retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, byteValue, length)
Case Else
RegCloseKey handle
Err.Raise 1001, , "Unsupported value type"
End Select
RegCloseKey handle ' Close the key and signal success
SetRegistryValue = (retVal = 0) ' signal success if the value was written correctly
End Function
To try and debug, make the changes mentioned below, then run your test. If the error message indicates the 'line number' is 123, then that error needs to be resolved to fix the issue. If there is no line # indicated, the error is elsewhere and can be fixed. We need to know the error number and description.
Please try the following:
Replace the following lines of code in Function RunReportAsPDF
SetRegistryValue HKEY_CURRENT_USER, ......
ErrorHandler:....
If Err.Number <> 0 Then strRegPath = ....
On Error GoTo Err_handler
With the following:
' Make sure the 123 (line number below) starts in the first column
123 SetRegistryValue HKEY_CURRENT_USER, strRegPath, "2", Left(prmPdfName, InStrRev(prmPdfName, "\") - 1)
Exit Function
ErrorHandler:
' Display the Error info, plus Line number
Msgbox "Error = & Err.Number & vbtab & Err.Description & vbcrlf & "At Line: " & Erl
If Err.Number <> 0 Then strRegPath = "Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder": Err.Clear: Resume 1
On Error GoTo Err_handler
I want to extract all the fields associated to my tables in my access database, to get an inventory of all the data objects. This has to populate a form I've created. I've copied an extract of code to determine whether an object in the database is a query or a table and I would like to alter this, if possible.
Any help will be appreciated
Option Compare Database
Option Explicit
Private Sub AddInventory(strContainer As String)
Dim con As DAO.Container
Dim db As DAO.Database
Dim doc As DAO.Document
Dim rst As DAO.Recordset
Dim intI As Integer
Dim strType As String
Dim varRetval As Variant
On Error GoTo HandleErr
' You could easily modify this, using the
' OpenDatabase() function, to work on any database,
' not just the current one.
varRetval = SysCmd(acSysCmdSetStatus, _
"Retrieving " & strContainer & " container information...")
Set db = CurrentDb
Set con = db.Containers(strContainer)
Set rst = db.OpenRecordset("zstblInventory")
For Each doc In con.Documents
If Not IsTemp(doc.Name) Then
' Handle the special queries case.
' Tables and queries are lumped together
' in the Tables container.
If strContainer = "Tables" Then
If IsTable(doc.Name) Then
strType = "Tables"
Else
strType = "Queries"
End If
Else
strType = strContainer
End If
rst.AddNew
rst("Container") = strType
rst("Owner") = doc.Owner
rst("Name") = doc.Name
rst("DateCreated") = doc.DateCreated
rst("LastUpdated") = doc.LastUpdated
rst.Update
End If
Next doc
ExitHere:
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
Exit Sub
HandleErr:
MsgBox Err.Number & ": " & Err.Description, , _
"AddInventory"
Resume ExitHere
End Sub
Private Sub RebuildInventory()
On Error GoTo HandleErr
DoCmd.Hourglass True
Me.lstInventory.RowSource = ""
Call CreateInventory
Me.lstInventory.RowSource = "SELECT ID, Container, Name, " & _
"Format([DateCreated],'mm/dd/yy (h:nn am/pm)') AS [Creation Date], " & _
"Format([lastUpdated],'mm/dd/yy (h:nn am/pm)') AS [Last Updated], " & _
"Owner FROM zstblInventory ORDER BY Container, Name;"
ExitHere:
DoCmd.Hourglass False
Exit Sub
HandleErr:
Resume ExitHere
End Sub
Private Sub CreateInventory()
If (CreateTable()) Then
' These routines use the status line,
' so clear it once everyone's done.
Call AddInventory("Tables")
Call AddInventory("Forms")
Call AddInventory("Reports")
Call AddInventory("Scripts")
Call AddInventory("Modules")
Call AddInventory("Relationships")
' Clear out the status bar.
Call SysCmd(acSysCmdClearStatus)
Else
MsgBox "Unable to create zstblInventory."
End If
End Sub
Private Function CreateTable() As Boolean
' Return True on success, False otherwise
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Dim strSQL As String
On Error GoTo HandleErr
Set db = CurrentDb()
db.Execute "DROP TABLE zstblInventory"
' Create zstblInventory
strSQL = "CREATE TABLE zstblInventory (Name Text (255), " & _
"Container Text (50), DateCreated DateTime, " & _
"LastUpdated DateTime, Owner Text (50), " & _
"ID AutoIncrement Constraint PrimaryKey PRIMARY KEY)"
db.Execute strSQL
' If you got here, you succeeded!
db.TableDefs.Refresh
CreateTable = True
ExitHere:
Exit Function
HandleErr:
Select Case Err
Case 3376, 3011 ' Table or Object not found
Resume Next
Case Else
CreateTable = False
End Select
Resume ExitHere
End Function
Private Function IsTable(ByVal strName As String)
Dim tdf As DAO.TableDef
Dim db As DAO.Database
On Error Resume Next
' Normally, in a function like this,
' you would need to refresh the tabledefs
' collection for each call to the function.
' Since this slows down the function
' by a very large measure, this time,
' just Refresh the collection the first
' time, before you call this function.
Set db = CurrentDb()
' See CreateTable().
'db.Tabledefs.Refresh
Set tdf = db.TableDefs(strName)
IsTable = (Err.Number = 0)
Err.Clear
End Function
Private Function IsTemp(ByVal strName As String)
IsTemp = Left(strName, 7) = "~TMPCLP"
End Function
Private Sub cmdCreateInventory_Click()
Call RebuildInventory
End Sub
Private Sub Detail0_Click()
End Sub
Private Sub Form_Open(Cancel As Integer)
Call RebuildInventory
End Sub
Check out the source code in this answer. You should be able to modify it to do what you need. Unless, as Remou pointed out in his comment, you are working with a pre-2000 version of Access.
Is there any way to bulk-export Microsoft Access code to files? I see I can export one file at a time, but there are hundreds and I'll be here all day. It there no "Export All" or multi-select export anywhere?
You can do this without having to write any code at all. From the menu, choose tools->analyze->database documenter.
This will give you a bunch of options to print out the code. You can then while viewing the report ether send it out to your PDF printer (if you have one). Or, simply print out to a text file printer. Or you can even then click on the word option in the report menu bar and the results will be sent out to word
The database documenter has provisions to print out all code, including code in forms.
So, in place of some of the suggested code examples you can do this without having to write any code at all. Do play with the additional options in the documenter. The documenter will produce HUGE volumes print out information for every single property and object in the database. So, if you don't un-check some of the options then you will easily empty a full size printer tray of paper. This documenter thus results in huge printouts.
To output all code to desktop, including code from forms and reports, you can paste this into a standard module and run it by pressing F5 or step through with F8. You may wish to fill in the name of the desktop folder first.
Sub AllCodeToDesktop()
''The reference for the FileSystemObject Object is Windows Script Host Object Model
''but it not necessary to add the reference for this procedure.
Dim fs As Object
Dim f As Object
Dim strMod As String
Dim mdl As Object
Dim i As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
''Set up the file.
''SpFolder is a small function, but it would be better to fill in a
''path name instead of SpFolder(Desktop), eg "c:\users\somename\desktop"
Set f = fs.CreateTextFile(SpFolder(Desktop) & "\" _
& Replace(CurrentProject.Name, ".", "") & ".txt")
''For each component in the project ...
For Each mdl In VBE.ActiveVBProject.VBComponents
''using the count of lines ...
i = VBE.ActiveVBProject.VBComponents(mdl.Name).CodeModule.CountOfLines
''put the code in a string ...
If i > 0 Then
strMod = VBE.ActiveVBProject.VBComponents(mdl.Name).codemodule.Lines(1, i)
End If
''and then write it to a file, first marking the start with
''some equal signs and the component name.
f.writeline String(15, "=") & vbCrLf & mdl.Name _
& vbCrLf & String(15, "=") & vbCrLf & strMod
Next
''Close eveything
f.Close
Set fs = Nothing
End Sub
To get special folders, you can use the list supplied by Microsoft.
Enumerating Special Folders: http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_higv.mspx?mfr=true
From: http://wiki.lessthandot.com/index.php/Code_and_Code_Windows
There is nothing in the interface to export more than one module at a time.
You can code your own "export all" equivalent easily:
Public Sub ExportModules()
Const cstrExtension As String = ".bas"
Dim objModule As Object
Dim strFolder As String
Dim strDestination As String
strFolder = CurrentProject.Path
For Each objModule In CurrentProject.AllModules
strDestination = strFolder & Chr(92) & objModule.Name & cstrExtension
Application.SaveAsText acModule, objModule.Name, strDestination
Next objModule
End Sub
Here's my version:
'============================================================'
' OutputCodeModules for Access
' Don Jewett, verion 2014.11.10
' Exports the following items from an Access database
' Modules
' Form Modules
' Report Modules
'
' Must be imported into Access database and run from there
'============================================================'
Option Explicit
Option Compare Database
Private Const KEY_MODULES As String = "Modules"
Private Const KEY_FORMS As String = "Forms"
Private Const KEY_REPORTS As String = "Reports"
Private m_bCancel As Boolean
Private m_sLogPath As String
'------------------------------------------------------------'
' >>>>>> Run this using F5 or F8 <<<<<<<<
'------------------------------------------------------------'
Public Sub OutputModuleHelper()
OutputModules
End Sub
Public Sub OutputModules(Optional ByVal sFolder As String)
Dim nCount As Long
Dim nSuccessful As Long
Dim sLine As String
Dim sMessage As String
Dim sFile As String
If sFolder = "" Then
sFolder = Left$(CurrentDb.Name, InStrRev(CurrentDb.Name, "\") - 1)
sFolder = InputBox("Enter folder for files", "Output Code", sFolder)
If sFolder = "" Then
Exit Sub
End If
End If
'normalize root path by removing trailing back-slash
If Right(sFolder, 1) = "\" Then
sFolder = Left(sFolder, Len(sFolder) - 1)
End If
'make sure this folder exists
If Not isDir(sFolder) Then
MsgBox "Folder does not exist", vbExclamation Or vbOKOnly
Exit Sub
End If
'get a new log filename
m_sLogPath = sFolder & "\_log-" & Format(Date, "yyyy-MM-dd-nn-mm-ss") & ".txt"
sLine = CurrentDb.Name
writeLog sLine
sMessage = sLine & vbCrLf
sLine = Format(Now, "yyyy-MM-dd nn:mm:ss") & vbCrLf
writeLog sLine
sMessage = sMessage & sLine & vbCrLf
'output modules
nCount = CurrentDb.Containers(KEY_MODULES).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_MODULES)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & KEY_MODULES & " exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
'output form modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_FORMS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_FORMS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Form Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
'output report modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_REPORTS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_REPORTS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Report Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
If Len(sMessage) Then
MsgBox sMessage, vbInformation Or vbOKOnly, "OutputModules"
End If
End Sub
Private Function outputContainerModules( _
ByVal sFolder As String, _
ByVal sKey As String) As Long
Dim n As Long
Dim nCount As Long
Dim sName As String
Dim sPath As String
On Error GoTo EH
'refactored this to use reference to Documents,
'but the object reference doesn't stick around
'and I had to roll back to this which isn't as pretty.
'but this works (and if it ain't broke...)
For n = 0 To CurrentDb.Containers(sKey).Documents.Count - 1
nCount = nCount + 1
sName = CurrentDb.Containers(sKey).Documents(n).Name
Select Case sKey
Case KEY_FORMS
sName = "Form_" & sName
Case KEY_REPORTS
sName = "Report_" & sName
End Select
sPath = sFolder & "\" & sName & ".txt"
DoCmd.OutputTo acOutputModule, sName, acFormatTXT, sPath, False
Next 'n
outputContainerModules = nCount
Exit Function
EH:
nCount = nCount - 1
Select Case Err.Number
Case 2289 'can't output the module in the requested format.
'TODO: research - I think this happens when a Form/Report doesn't have a module
Resume Next
Case Else
Dim sMessage As String
writeError Err, sKey, sName, nCount
sMessage = "An Error ocurred outputting " & sKey & ": " & sName & vbCrLf & vbCrLf _
& "Number " & Err.Number & vbCrLf _
& "Description:" & Err.Description & vbCrLf & vbCrLf _
& "Click [Yes] to continue with export or [No] to stop."
If vbYes = MsgBox(sMessage, vbQuestion Or vbYesNo Or vbDefaultButton2, "Error") Then
Resume Next
Else
m_bCancel = True
outputContainerModules = nCount
End If
End Select
End Function
Private Function writeFile( _
ByVal sPath As String, _
ByRef sMessage As String, _
Optional ByVal bAppend As Boolean) As Boolean
'Dim oFSO as Object
'Dim oStream as Object
'Const ForWriting As Long = 2
'Const ForAppending As Long = 8
'Dim eFlags As Long
Dim oFSO As FileSystemObject
Dim oStream As TextStream
Dim eFlags As IOMode
On Error GoTo EH
'Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oFSO = New FileSystemObject
If bAppend Then
eFlags = ForAppending
Else
eFlags = ForWriting
End If
Set oStream = oFSO.OpenTextFile(sPath, eFlags, True)
oStream.WriteLine sMessage
writeFile = True
GoTo CLEAN
EH:
writeFile = False
CLEAN:
If Not oFSO Is Nothing Then
Set oFSO = Nothing
End If
If Not oStream Is Nothing Then
Set oStream = Nothing
End If
End Function
Private Sub writeError( _
ByRef oErr As ErrObject, _
ByVal sType As String, _
ByVal sName As String, _
ByVal nCount As Long)
Dim sMessage As String
sMessage = "An Error ocurred outputting " & sType & ": " & sName & " (" & nCount & ")" & vbCrLf _
& "Number " & oErr.Number & vbCrLf _
& "Description:" & oErr.Description & vbCrLf & vbCrLf
writeLog sMessage
End Sub
Private Sub writeLog( _
ByRef sMessage As String)
On Error GoTo EH
writeFile m_sLogPath, sMessage & vbCrLf, True
Exit Sub
EH:
'swallow errors?
End Sub
Private Function isDir(ByVal sPath As String) As Boolean
On Error GoTo EH
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If Dir$(sPath & ".", vbDirectory) = "." Then
isDir = True
ElseIf Len(sPath) = 3 Then
If Dir$(sPath, vbVolume) = Left(sPath, 1) Then
isDir = True
End If
End If
Exit Function
EH:
isDir = False
End Function