i declared the global variable in the Module1 and when i was trying to use it in another module it is showing the runtime error '5':\invalid procedure call or argument. i was unable to find the problem please provied the solution for this problem
Declaring global variable:
Function getFilePath() As String
getFilePath = FilePath
Set FilePath = "C:\quadyster\R3AgreementDetails"
End Function
Implementing of globalvariable:
Private Sub SendAgreement_Click()
If (Not IsNull(Me.RequestFrom) And Not IsNull(Me.RequestReference)) Then
Call AttachR3ServiceAgreement(Module1.FilePath, tripObjectFormation, "Agreement")
Me.AgreementDate = Now()
Else
MsgBox "Please provide 'RequestFrom' and 'RequestReference' to proceed." & vbNewLine & vbNewLine & _
"Press Ok to continue.", vbOKOnly, "Alert!!!"
End If
End Sub
this is the calling function
Public Function AttachR3ServiceAgreement(FilePath As String, tripData As
tripDetails, requestType As String)
Here error is occured:
Set objStream = objFSO.OpenTextFile(fileHTML, ForReading)
You have a syntax error there: Set can only be used with objects.
Public FilePath As String
Function getFilePath() As String
FilePath = "C:\quadyster\R3AgreementDetails"
getFilePath = FilePath
End Function
Private Sub SendAgreement_Click()
If (Not IsNull(Me.RequestFrom) And Not IsNull(Me.RequestReference)) Then
Call AttachR3ServiceAgreement(Module1.FilePath, tripObjectFormation, "Agreement")
Me.AgreementDate = Now()
Else
MsgBox "Please provide 'RequestFrom' and 'RequestReference' to proceed." & vbNewLine & vbNewLine & _
"Press Ok to continue.", vbOKOnly, "Alert!!!"
End If
End Sub
Related
I try to open a form in another database by using GetObject. Unfortunately I have to open a second instance of the database, but I would like to use the active instance of that database instead (if loaded). TO accomplish this I need to set an object reference to the running instance of that db.
What I currently use is the function below. This function first tries to activate the running instance of the database using its screen name, and if this generates an error the database and the form are loaded. However, if the database is already loaded I want to be able to load the form as well.
On lesser problem is if the error procedure to load the db and form generates an error, the error routine is not followed. How should I manage that?
Anyone has an idea?
I'm Using Access 2016
Thx.
Peter
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
This is not an easy task, but it can be accomplished by using some WinAPI window functions.
Essentially, you want to get an Access Application object by using the window title.
I'm going to assume you haven't got any unicode characters in that window title, else, we'll need something a little more complex.
First, declare our WinAPI functions:
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
FindWindowExA is used to find the window with the specified title. AccessibleObjectFromWindow is used to get the COM object of that window.
Then, we declare some constants to be used for AccessibleObjectFromWindow:
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM As Long = &HFFFFFFF0 'To identify the object type
Then, we can write the function
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Dim hwndAppDb As LongPtr
hwndAppDb = FindWindowExA (,,,strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
Dim guid() As Byte
guid = Application.GuidFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
End If
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
I'm not going to discuss the point of chained error handlers, but you can just review this answer for that. Note that resetting the error handler resets the Err object as well, so you might first want to store error number and description if you want to use that.
This worked like a charm, thank you so much! I never figured this out by myself.
It seems that after an adjustment of the code there is no issue related to the nested errors too. I needed to add a maximize call because mu forms are showed related to the screen and this causes an invisible form when the other database was minimized. The final code is now
Option Compare Database
Option Explicit
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, _
Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, _
Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, _
ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM = &HFFFFFFF0 'To identify the object type
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
Dim hwndAppDb As LongPtr
'Find the Db handle
hwndAppDb = FindWindowExA(, , , strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
'Activate DB if open
Dim guid() As Byte
guid = Application.GUIDFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
Else
'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
End If
If Nz(strOpenForm, "") <> "" Then
objDb.RunCommand acCmdAppMaximize
objDb.DoCmd.OpenForm strOpenForm
objDb.Run "CenterForm", strOpenForm, False, False, False, 0
End If
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_OpenExtDb" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
Again, thank you!
Peter
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 have VBA function in Access that should return the path of the special folder (MyDocuments, Desktop, etc) based on a string variable I passed it. However, I'm always getting the public desktop "C:\Users\Public\Desktop" instead of what I pass in. Here is the function code:
Function SpecialFolderPath(whichFolder As String) As String
Debug.Print whichFolder
Dim objWSHShell As Object
Dim strSpecialFolderPath
Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders(whichFolder)
Debug.Print SpecialFolderPath
Set objWSHShell = Nothing
Exit Function
ErrorHandler:
MsgBox "Error finding " & strSpecialFolder, vbCritical + vbOKOnly, "Error"
End Function
So, no matter what I pass in as whichFolder, I always get C:\Users\Public\Desktop. How can I correct this?
EDIT:
I'm calling this function in the following ways:
- DoCmd.OutputTo acOutputQuery, "BoxForecasting_Jobs", "ExcelWorkbook(*.xlsx)", SpecialFolderPath("MyDocuments") & "\BoxForecastByJobs.xlsx", False, "", , acExportQualityPrint
-Set oWB = oXL.Workbooks.Open(SpecialFolderPath("MyDocuments") & "\BoxForecastByJobs.xlsx")
Change this line:
SpecialFolderPath = objWSHShell.SpecialFolders(whichFolder)
to:
SpecialFolderPath = objWSHShell.SpecialFolders("" & whichFolder & "")
I've tweaked your code a bit. Added WhichFolder = "Templates", made it a sub and returned the result through a msgbox.
My end result:
It is a collection. See what's in it using a for each loop.
Set wshshell = CreateObject("WScript.Shell")
For each thing in wshshell.SpecialFolders
wscript.echo thing
Next
These are the names it accepts.
AllUsersDesktop
AllUsersStartMenu
AllUsersPrograms
AllUsersStartup
Desktop
Favorites
Fonts
MyDocuments
NetHood
PrintHood
Programs
Recent
SendTo
StartMenu
Startup
Templates
I have a split database where the backend is located remotely; when I get the error "Network access has been interrupted" I want to log something on a local table for future access. After creating a system for this I found out that when the connection is lost to the remote backend the local tables also become inaccessible.
While I don't think there is necessarily a solution to this I want to find out why the local tables aren’t accessible when clearly they shouldn't require a network connection to be used. The following is the code for my function that I use to try and log locally.
Public Function LogTempError(ByVal lngErrNumber As Long, _
ByVal strErrDescription As String, _
strCallingProc As String, _
Optional varParameters As Variant, _
Optional blnSHOW_USER As Boolean = True) As Boolean
On Error GoTo Err_Handler
'Set warnings to True just in case the error happened while they were set to false.
DoCmd.SetWarnings True
Dim rs As DAO.Recordset
Set rs = DBEngine(0)(0).OpenRecordset("TempErrorTable", dbOpenDynaset, dbAppendOnly)
With rs
.AddNew
!ERROR_LOG_NUMBER = lngErrNumber
!ERROR_LOG_USERID = NetworkUserName()
!ERROR_LOG_DESCRIPTION = strErrDescription & " logged from Temp Table"
!ERROR_LOG_TIMESTAMP = Now()
!ERROR_LOG_FORM = strCallingProc
.Update
End With
Exit_Handler:
On Error Resume Next
rs.Close
Set rs = Nothing
Exit Function
Err_Handler:
If DateDiff("s", dteLAST_ERROR_TIME, Now()) > 20 Or lngLAST_ERROR_NUMBER <> lngErrNumber Then
' If there are more errors that can't be logged, simply email the errors.
SendEmail "First Unloggable error", "Error Num: " & Err.Number & " Error Description: " & strErrDescription & " From: " & strCallingProc
SendEmail "Second Unloggable error", "Error Num: " & Err.Number & " Error Description: " & Err.Description & " From: " & strCallingProc
MsgBox "An error occured that wasn't able to be logged, a message was sent to Database Administrator on your behalf.", vbInformation, "Notification Sent"
End If
Resume Exit_Handler
End Function
Try this slightly stripped-down version, which opens the connection to TempErrorTable on first use, and keeps the connection open. Let it stop on errors within LogTempError so you can see where the TempErrorTable update is failing.
Public Function LogTempError(ByVal lngErrNumber As Long, _
ByVal strErrDescription As String, _
strCallingProc As String, _
Optional varParameters As Variant, _
Optional blnSHOW_USER As Boolean = True) As Boolean
Static rs As Recordset
On Error GoTo 0
DoCmd.SetWarnings True
If rs Is Nothing Then ' open recordset on first use
Set rs = CurrentDb.OpenRecordset("TempErrorTable", dbOpenDynaset, dbAppendOnly)
End If
With rs
.AddNew
!ERROR_LOG_NUMBER = lngErrNumber
!ERROR_LOG_USERID = NetworkUserName()
!ERROR_LOG_DESCRIPTION = strErrDescription & " logged from Temp Table"
!ERROR_LOG_TIMESTAMP = Now()
!ERROR_LOG_FORM = strCallingProc
.Update
End With
Exit Function
I have a button in my Access 2007 form. On click, I need to open filedialog. I dont know how to attach the file selected to the 'Memo' field of a table using DAO.
Form details
Form : OrderForm
Field: txtManagerProfile
Button : btnFileBrowse
Table details
Table :ManagersProfile
Memo field : Profile
Requirement:
'Profile' in table should accept any file and save it. Once the user selects the file, I need to show a open icon near to the 'txtManagerProfile' field in the form. On clicking the open button , I need to open any file. I am not used to this requirement before. Someone pls help. I am using DAO for populating other fields in the form.
In the below code I have a form with a text box named txtManagerProfile and a button named btnFileBrowse. When I click on the btnFileBrowse button a browser pops up that lets you browse to the file. When you select the file, the path is stored in the txtManagerProfile text box. If you double click on the txtManagerProfile text box the file gets opened up.
Here is the code behind the form:
'the open filename api
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As gFILE) As Long
' the gFILE type needed by the open filename api
Private Type gFILE
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Function FileToOpen(Optional StartLookIn) As String
'Purpose: Calls the open file api to let the user select the file to open
'returns: string value which contains the path to the file selected. "" = no file seleted
Dim ofn As gFILE, Path As String, filename As String, a As String
ofn.lStructSize = Len(ofn)
ofn.lpstrFilter = "All Files (*.*)"
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
If Not IsMissing(StartLookIn) Then ofn.lpstrInitialDir = StartLookIn Else ofn.lpstrInitialDir = "f:\Quoting"
ofn.lpstrTitle = "SELECT FILE"
ofn.Flags = 0
a = GetOpenFileName(ofn)
If (a) Then
Path = Trim(ofn.lpstrFile)
filename = Trim(ofn.lpstrFileTitle)
If Dir(Path) <> "" Then
FileToOpen = -1
FileToOpen = Trim(ofn.lpstrFile)
Else
FileToOpen = ""
Path = ""
filename = ""
End If
End If
FileToOpen = Path
End Function
Private Sub btnFileBrowse_Click()
Dim MyPath As String
MyPath = FileToOpen
If (VBA.Strings.Len(MyPath & "") > 0) Then txtManagerProfile = MyPath
End Sub
Private Sub txtManagerProfile_DblClick(Cancel As Integer)
On Error GoTo Err_My_Click
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
'IF THE FILE DOES NOT EXIST THEN DISPLAY THE MESSAGE AND EXIT THE SUBROUTINE
If (fso.FileExists(txtManagerProfile) = False) Then
MsgBox "THE FILE PATH IS INCORRECT.", , "ERROR: INVALID FILE PATH"
Exit Sub
End If
'USED TO CHECK IF THE FILE IS ALREADY OPENED AND LOCKED BY ANOTHER USER.
Open txtManagerProfile For Binary Access Read Write Lock Read Write As #1
Close #1
Application.FollowHyperlink txtManagerProfile
Exit_My_Click:
Exit Sub
Err_My_Click:
If Err.Number = 486 Then
MsgBox "YOU DO NOT HAVE THE PROGRAM INSTALLED THAT " & vbNewLine & _
"IS USED TO VIEW THIS FILE. CONTACT YOUR IT " & vbNewLine & _
"MANAGER AND HAVE HIM/HER INSTALL THE NEEDED " & vbNewLine & _
"APPLICATION.", , "ERROR: MISSING APPLCIATION"
ElseIf Err.Number = 490 Then
MsgBox "THE FILE PATH IS INCORRECT.", , "ERROR: INVALID FILE PATH"
ElseIf Err.Number = 70 Or Err.Number = 75 Then
MsgBox "THE FILE IS OPENED/LOCKED BY ANOTHER USER." & vbNewLine & _
"THEY WILL HAVE TO CLOSE IT BEFORE YOU CAN " & vbNewLine & _
"OPEN IT THROUGH PDC.", , "ERROR: FILE ALREADY OPEN"
Else
MsgBox ("ERROR MESSAGE: " & Err.Description & vbNewLine & _
"ERROR NUMBER: " & Err.Number & vbNewLine & _
"ERROR SOURCE: " & Err.Source)
End If
Resume Exit_My_Click
End Sub
EDIT:
You could do something like the following to save the path into a table somewhere:
Private Sub cmdSave_Click()
If (VBA.Strings.Len(txtManagerProfile & "") <> 0) Then
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO MyTable (linkfile) VALUES ('" & _
txtManagerProfile & "')"
DoCmd.SetWarnings True
MsgBox "SUCCESSFULLY SAVED", , "SUCCESS"
Else
MsgBox "YOU MUST SELECT A FILE FIRST BEFORE SAVING", , "ERROR: NO FILE"
End If
End Sub