Related
There is a button on a report that exports the underlying query of the report to excel. This function works fine as it would but I need it to take the criteria of the report. I have a massive reporting manager that will set the criteria for the report and then will open it up.
To make it easy, I want to pass me.filter to a variable which works in a different sub, but here my problem is that I need to pass the filter to be properly formatted for an sql statement I assume? The other sub just uses it as a [WhereCondition] for an open report command.
For clarification, the portion getreportsource() is a module that gets the reports source and it works fine.
Here are some example outputs of the variables as well as the code:
strRptName: TotalSalesForYear
strRptSource: qryMainDashboard
FilterCondition: TxnDate >= #11/1/2017# AND TxnDate <= #11/30/2017#
Private Sub cmdExcel_Click()
Dim strRptName As String
Dim strRptSource As String
Dim vardate As String
Dim varExportPath As String
Dim FilterCondition As String
Dim oExcel
FilterCondition = Me.filter
' Get the Report Name
strRptName = Screen.ActiveReport.Name
' Get the RecordSource of the Report from a module
strRptSource = GetReportSource(strRptName)
'Present Date
vardate = Format$(Now(), "YYYY.MM.DD_HH-mm-ss")
'Path of export
varExportPath = "C:\Users\Public\Downloads\"
'Check for terminating backslash ExportLinkReportsOut filepath.
If Right(varExportPath, 1) <> "\" Then
varExportPath = varExportPath & "\"
End If
varExportPath = varExportPath & strRptName & ".xlsx"
' set dao and create temp table
Dim cdb As DAO.Database, qdf As DAO.QueryDef
Const tempTableName = "_tempTbl"
Set cdb = CurrentDb
'deletes temp table and handles error
On Error Resume Next
DoCmd.DeleteObject acTable, tempTableName
On Error GoTo 0
Set qdf = cdb.CreateQueryDef("")
qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] where filtercondition"
qdf.Execute
Set qdf = Nothing
Set cdb = Nothing
' export spreadsheet with the temp table, the export path, and then open the spreadsheet
DoCmd.TransferSpreadsheet acExport, , tempTableName, varExportPath, True
Set oExcel = GetObject(varExportPath)
oExcel.Application.Visible = True
oExcel.Parent.Windows(1).Visible = True
End Sub
Everything works when I change qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] where filtercondition" to qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] "
Problem is there is no filter when I drop filtercondition, obviously.
The error I keep getting is "Run-time error '3061': Too few paramters. Expected 1."
Anyone have any pointers?
The problem is that you aren't concatenating the filter condition. Your query just states WHERE filtercondition, not WHERE TxnDate >= #11/1/2017# AND TxnDate <= #11/30/2017#
Change qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] where filtercondition" to qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] WHERE " & filtercondition
I am working on a VBA macro which connects to my database on SQL Server and run some queries and save the results on CSV files... it works fine just when the queries returns data but i have days where the query doesn't return any results, just an empty table. I made a temporary solution based on checking the date and according it the macro runs that query or no... I want to make it other way now in my code so that i don't need to change the date everytime manually...
I tried these solutions :
If (objMyRecordset.EOF = False) Or (objMyRecordset.BOF = False) Then
Also this
If objMyRecordset.RecordCount <> 0 Then
but the problem is my Recordset is empty because the query doesn't return any rows so it shows me error in objMyRecordset.Open
I want to add a line of code like this for example :
'// Pseudo Code
If (the query doesn't return result) Then
( just the headers will be save on my file )
Else
(do the rest of my code)
End If
Here is my code. Any suggestions please ? Thank you very much.
Sub Load_after_cutoff_queryCSV()
Dim objMyConn As ADODB.Connection
Dim objMyCmd As ADODB.Command
Dim objMyRecordset As ADODB.Recordset
Dim fields As String
Dim i As Integer
Set objMyConn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set objMyRecordset = New ADODB.Recordset
'Open Connection
objMyConn.ConnectionString = "Provider=SQLOLEDB;Data Source=*****;User ID=*****;Password=*****;"
objMyConn.Open
'Set and Excecute SQL Command
Set objMyCmd.ActiveConnection = objMyConn
objMyCmd.CommandText = "SELECT * FROM [vw_X86_LOAD_AFTER_CUTOFF_REPORT_GAMMA]"
objMyCmd.CommandType = adCmdText
'Open Recordset
Set objMyRecordset.Source = objMyCmd
objMyRecordset.Open
Workbooks.Open Filename:="C:\Reports\load_after_cutoff_postGamma.csv"
Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Activate
ActiveSheet.Range("A2").CopyFromRecordset objMyRecordset
For i = 0 To objMyRecordset.fields.Count - 1
Worksheets("load_after_cutoff_postGamma").Cells(1, i + 1) = objMyRecordset.fields(i).name
Next i
Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Cells.EntireColumn.AutoFit
Workbooks("load_after_cutoff_postGamma.csv").Close SaveChanges:=True
MsgBox "Your file has been saved as load_after_cutoff_postGamma.csv"
If you experience problems connecting to your server then this is due to any of the following:
an incorrect connection string
incorrect credentials
the server is not reachable (for example: network cable disconnected)
the server is not up and running
Sending a query to a server which results in an empty recordset is not a reason for an ADODB.Connection to fail.
Here is a little bit of code for you to try and debug the connection in a first step and then the query in a second step:
Option Explicit
Public Sub tmpSO()
Dim strSQL As String
Dim strServer As String
Dim strDatabase As String
Dim OutMail As Outlook.MailItem
Dim rstResult As ADODB.Recordset
Dim conServer As ADODB.Connection
Dim OutApp As Outlook.Application
strServer = "."
strDatabase = "master"
Set conServer = New ADODB.Connection
conServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
& "DATA SOURCE=" & strServer & ";" _
& "INITIAL CATALOG=" & strDatabase & ";" _
& "User ID='UserNameWrappedInSingleQuotes'; " _
& "Password='PasswordWrappedInSingleQuotes'; "
On Error GoTo SQL_ConnectionError
conServer.Open
On Error GoTo 0
strSQL = "set nocount on; "
strSQL = strSQL & "select * "
strSQL = strSQL & "from sys.tables as t "
strSQL = strSQL & "where t.name = ''; "
Set rstResult = New ADODB.Recordset
rstResult.ActiveConnection = conServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0
If Not rstResult.EOF And Not rstResult.BOF Then
ThisWorkbook.Worksheets(1).Range("A1").CopyFromRecordset rstResult
' While Not rstResult.EOF And Not rstResult.BOF
' 'do something
' rstResult.MoveNext
' Wend
Else
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms675546(v=vs.85).aspx
Select Case conServer.State
'adStateClosed
Case 0
MsgBox "The connection to the server is closed."
'adStateOpen
Case 1
MsgBox "The connection is open but the query did not return any data."
'adStateConnecting
Case 2
MsgBox "Connecting..."
'adStateExecuting
Case 4
MsgBox "Executing..."
'adStateFetching
Case 8
MsgBox "Fetching..."
Case Else
MsgBox conServer.State
End Select
End If
Set rstResult = Nothing
Exit Sub
SQL_ConnectionError:
MsgBox "Couldn't connect to the server. Please make sure that you have a working connection to the server."
Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = "Problems connecting to database '" & strDatabase & "' hosted on the server '" & strServer & "'"
.HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
"</span><br><br>Error report from the file '" & _
"<span style=""color:blue"">" & ThisWorkbook.Name & _
"</span>' located and saved on '<span style=""color:blue"">" & _
ThisWorkbook.Path & "</span>'.<br>" & _
"Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
"Computer Name: <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
"Logged in as: <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
"Domain Server: <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
"User DNS Domain: <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
"Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
"Excel Version: <span style=""color:green;"">" & Application.Version & "</span><br>" & _
"<br><span style=""font-size:10px""><br>" & _
"<br><br>---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
SQL_StatementError:
MsgBox "There seems to be a problem with the SQL Syntax in the programming."
Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = "Problems with the SQL Syntax in file '" & ThisWorkbook.Name & "'."
.HTMLBody = "<span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---" & _
"</span><br><br>" & _
"Error report from the file '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Name & _
"</span>" & _
"' located and saved on '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Path & _
"</span>" & _
"'.<br>" & _
"It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
"SQL-Code causing the problems:" & _
"<br><br><span style=""color:green;"">" & _
strSQL & _
"</span><br><br><span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
End Sub
Note, that the above code clearly distinguishes between (first) connecting to the server and then (afterwards) issuing a query to the server to retrieve some data. Both steps are separated and there is a different error handler for either case.
Furthermore, the above sample code also results in an empty recordset being returned. But the code is able to handle that incident with yet another error handler.
If the connection fails or if the SQL syntax being sent to the server contains error(s) then the above code will automatically generate an error email (using Outlook) with some details for you to check the connection and the SQL syntax.
you should go with your .EOF solution. Here is an example of mine, which I use regularly.
Sub AnySub()
''recordsets
Dim rec as ADODB.Recordset
''build your query here
sSql = "SELECT * FROM mytable where 1=0" ''just to have no results
''Fire query
Set rec = GetRecordset(sSql, mycnxnstring)
''and then loop throug your results, if there are any
While rec.EOF = False
''do something with rec()
rec.MoveNext
Wend
End sub
Here the Function GetRecordset() is given by:
Function GetRecordset(strQuery As String, connstring As String) As Recordset
Dim DB As ADODB.Connection
Dim rs As ADODB.Recordset
Set DB = New ADODB.Connection
With DB
.CommandTimeout = 300
.ConnectionString = connstring
.Open
End With
Set GetRecordset = DB.Execute(strQuery)
End Function
Hope this helps.
I've got code in a project to read data from a Sheet into a recordset. The VBA code is password protected.
For testing I simplified the code, as shown below:
Option Explicit
Sub sTest()
Dim dbtmp As DAO.Database
Set dbtmp = OpenDatabase(Application.ActiveWorkbook.FullName, False, True, _
"Excel 8.0;HDR=Yes")
dbtmp.Close
Set dbtmp = Nothing
End Sub
Whenever I run this code from a Userform, after closing excel, I get prompted for the VBAProject password. Depending on the, I guess, number of modules in the workbook, I've got to cancel, at least, twice.
I've been breaking my head over this for the last week, read every post on the net I could find, but didn't find a solution yet.
As stated by Miqi180, this issue occurs when references to the workbook are not properly cleared; see Microsoft Knowledge Database
It could also occur when Office AddIns are installed.
There were/are some known issues:
Acrobat PDFMaker COM Addin
Fixed in Acrobat 11.0.1
Dropbox
Not yet fixed; workaround
Other Addin?
Uncheck 'OLE Automation' in the References window:
I have experienced the same problem in an Outlook project which opens an Excel file, so contrary to what others have speculated, it is not directly related to database (ADO or DAO) technology.
From the Microsoft Knowledge Database:
SYMPTOMS
After running a macro that passes a reference for a workbook
containing a password-protected VBA project to an ActiveX dynamic-link
library (DLL), you are prompted for the VBA project password when
Excel quits.
CAUSE
This problem occurs if the ActiveX DLL does not properly release
the reference to the workbook that contains the password-protected VBA
project.
The problem typically occurs when a circular reference between objects exists and the password prompt appears if the objects hold onto a reference for a protected workbook when Excel is closed.
Example: objectA stores a reference to objectB, and objectB stores a reference to objectA. The two objects are not destroyed unless you explicitly set objectA.ReferenceToB = Nothing or objectB.ReferenceToA = Nothing.
As I cannot replicate the symptoms by running your code on my computer, my guess is that you have modified your code for Stackoverflow in a way that removes the problem, e.g. by redefining public variables within the scope of the procedure.
This is a problem that has intermittently plagued my own Excel VBA add-ins for a small number of customers. I've documented the problem in my online documentation: VB Password Prompt.
While working on a specific situation for a client, I came up with a solution. I don't know if it only works for his situation (on just my machine) or if it is more widely applicable.
Insert the line "ThisWorkbook.Saved = True" at the end of the Workbook_BeforeClose event:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' blah blah before close code
ThisWorkbook.Saved = True
End Sub
If anyone has a chance to try this, could you let me know if it helps for you and/or your clients.
DAO isn't a great platform for reading data out of Excel files.
Actually, none of the available Microsoft database driver technologies are - they've all got some memory leaks, and the older ones create a hidden instance of Excel.exe - so anything in the VBA project (like, for example, a missing library or an event that calls noncompiling code) will raise the kind of errors that would make Excel think you are attempting to access the code.
Here's some code that uses ADODB, a more recent database technology that may work around any specific problems with DAO.
I haven't had time to strip out all the stuff that's irrelevant to your request - apologies, there's a lot of it! - but leaving in all those alternative connection strings is probably quite helpful for you: anyone who gets this kind of problem needs to need to play around a little, and work out which technology works by trial and error:
Public Function FetchRecordsetFromWorkbook(ByVal SourceFile As String, _
ByVal SourceRange As String, _
Optional ReadHeaders As Boolean = True, _
Optional StatusMessage As String = "", _
Optional GetSchema As Boolean = False, _
Optional CacheFile As String = "" _
) As ADODB.Recordset
Application.Volatile False
' Returns a static persistent non-locking ADODB recordset from a range in a workbook
' If your range is a worksheet, append "$" to the worksheet name. A list of the 'table'
' names available in the workbook can be extracted by setting parameter GetSchema=True
' If you set ReadHeaders = True the first row of your data will be treated as the field
' names of a table; this means that you can pass a SQL query instead of a range or table
' If you set ReadHeaders = False, the first row of your data will be treatd as data; the
' column names will be allocated automatically as 'F1', 'F2'...
' StatusMessage returns the rowcount if retrieval proceeds without errors, or '#ERROR'
' Be warned, the Microsoft ACE database drivers have memory leaks and stability issues
On Error GoTo ErrSub
Const TIMEOUT As Long = 60
Dim objConnect As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strConnect As String
Dim bFileIsOpen As Boolean
Dim objFSO As Scripting.FileSystemObject
Dim i As Long
Dim TempFile As String
Dim strTest As String
Dim SQL As String
Dim strExtension As String
Dim strPathFull As String
Dim timeStart As Single
Dim strHeaders As String
Dim strFilter As String
If SourceFile = "" Then
Exit Function
End If
' Parse out web folder paths
If Left(SourceFile, 5) = "http:" Then
SourceFile = Right(SourceFile, Len(SourceFile) - 5)
SourceFile = Replace(SourceFile, "%20", " ")
SourceFile = Replace(SourceFile, "%160", " ")
SourceFile = Replace(SourceFile, "/", "\")
End If
strPathFull = SourceFile
If Len(Dir(SourceFile)) = 0 Then
Err.Raise 1004, APP_NAME & "GetRecordsetFromWorkbook", _
"#ERROR - file '" & SourceFile & "' not found."
Exit Function
End If
Set objFSO = FSO
strExtension = GetExtension(strPathFull)
bFileIsOpen = FileIsOpen(SourceFile)
If Not bFileIsOpen Then
TempFile = objFSO.GetSpecialFolder(2).Path & "\" & TrimExtension(objFSO.GetTempName()) _
& "." & strExtension
objFSO.CopyFile SourceFile, TempFile, True
SourceFile = TempFile
End If
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And _
InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
strHeaders = "HDR=Yes"
ElseIf ReadHeaders = True Then
strHeaders = "HDR=Yes"
Else
strHeaders = "HDR=No"
End If
Select Case strExtension
Case "xls"
'strConnect = "ODBC;DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "ReadOnly=1;DBQ=" & Chr(34) & SourceFile & Chr(34) & ";" _
' & ";Extended Properties=" &Chr(34) & "HDR=No;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
'strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Chr(34) & SourceFile & _
' Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders _
' & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & _
Chr(34) & ";Persist Security Info=True;Extended Properties=" & _
Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case "xlsx"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & _
Chr(34) & ";Persist Security Info=True;Extended Properties=" & Chr(34) & _
"Excel 12.0 Xml;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case "xlsm"
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
' "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & _
' ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & _
' ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & _
Chr(34) & ";Persist Security Info=True;Extended Properties=" & Chr(34) _
& "Excel 12.0 Macro;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case "xlsb"
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1; _
' DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & _
' ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & _
' ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
' This ACE driver is unstable on xlsb files... But it's more likely to return a result, if you don't mind crashes:
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & _
";Persist Security Info=True;Extended Properties=" & Chr(34) & "Excel 12.0;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case Else
Err.Raise 999, APP_NAME & "GetRecordsetFromWorkbook", "#ERROR - file format not known"
End Select
On Error GoTo ErrSub
'SetTypeGuessRows
timeStart = VBA.Timer
Set objConnect = New ADODB.Connection
With objConnect
.ConnectionTimeout = TIMEOUT
.CommandTimeout = TIMEOUT
.Mode = adModeRead
.ConnectionString = strConnect
.Open strConnect, , , adAsyncConnect
Do While .State > adStateOpen
If VBA.Timer > timeStart + TIMEOUT Then
Err.Raise -559038737, _
APP_NAME & " GetRecordsetFromWorkbook", _
"Timeout: the Excel data connection object did not respond in the " _
& TIMEOUT & "-second interval specified by this application."
Exit Do
End If
If .State > adStateOpen Then Sleep 100
If .State > adStateOpen Then Sleep 100
Loop
End With
Set rst = New ADODB.Recordset
timeStart = VBA.Timer
With rst
.CacheSize = 8
.PageSize = 8
.LockType = adLockReadOnly
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And _
InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
SQL = SourceRange
Else
.MaxRecords = 8192
SQL = "SELECT * FROM [" & SourceRange & "] "
' Exclude empty rows from the returned data using a 'WHERE' clause.
With objConnect.OpenSchema(adSchemaColumns)
strFilter = ""
.Filter = "TABLE_NAME='" & SourceRange & "'"
If .EOF Then
.Filter = 0
.MoveFirst
End If
Do While Not .EOF
If UCase(!TABLE_NAME) = UCase(SourceRange) Then
Select Case !DATA_TYPE
Case 2, 3, 4, 5, 6, 7, adUnsignedTinyInt, adNumeric
' All the numeric types you'll see in a JET recordset from Excel
strFilter = strFilter & vbCrLf & " AND [" & !COLUMN_NAME & "] = 0 "
Case 130, 202, 203, 204, 205
' Text and binary types that pun to vbstring or byte array
strFilter = strFilter & vbCrLf & " AND [" & !COLUMN_NAME & "] = '' "
End Select
' Note that we don't try our luck with the JET Boolean data type
End If
.MoveNext
Loop
.Close
End With
If strFilter <> "" Then
strFilter = Replace(strFilter, vbCrLf & " AND [", " [", 1, 1)
strFilter = vbCrLf & "WHERE " & vbCrLf & "NOT ( " & strFilter & vbCrLf & " ) "
SQL = SQL & strFilter
End If
End If
.Open SQL, objConnect, adOpenForwardOnly, adLockReadOnly, adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Retrieving data" & String(i, ".")
If VBA.Timer > timeStart + TIMEOUT Then
Err.Raise -559038737, _
APP_NAME & " Fetch data", _
"Timeout: the Excel Workbook did not return data in the " & _
TIMEOUT & "-second interval specified by this application."
Exit Do
End If
If .State > 1 Then Sleep 100 ' There's a very slight performance gain doing it this way
If .State > 1 Then Sleep 100
Loop
End With
If rst.State = 1 Then
CacheFile = objFSO.GetSpecialFolder(2).Path & "\" & TrimExtension(objFSO.GetTempName()) & ".xml"
rst.Save CacheFile, adPersistXML ' , adPersistADTG
rst.Close
End If
Set rst = Nothing
objConnect.Close
objConnect.Errors.Clear
Set objConnect = Nothing
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.StayInSync = False
rst.Open CacheFile ', , adOpenStatic, adLockReadOnly, adCmdFile
StatusMessage = rst.RecordCount
Set FetchRecordsetFromWorkbook = rst
ExitSub:
On Error Resume Next
Set rst = Nothing
objConnect.Close
Set objConnect = Nothing
If (bFileIsOpen = False) And (FileIsOpen(SourceFile) = True) Then
For i = 1 To Application.Workbooks.Count
If Application.Workbooks(i).Name = Filename(SourceFile) Then
Application.Workbooks(i).Close False
Exit For
End If
Next i
End If
Exit Function
ErrSub:
StatusMessage = ""
StatusMessage = StatusMessage & ""
If InStr(Err.Description, "not a valid name") Then
StatusMessage = StatusMessage & "Cannot read the data from your file: "
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & Err.Description
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & "It's possible that the file has been locked, _
but the most likely explanation is that the file _
doesn't contain the named sheet or range you're _
trying to read: check that you've saved the _
correct range name with the correct file name."
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & "If this error persists, please contact the Support team."
MsgBox StatusMessage, vbCritical, APP_NAME & ": data access error:"
StatusMessage = "#ERROR " & StatusMessage
ElseIf InStr(Err.Description, "Could not find the object '& SourceRange") Then
StatusMessage = StatusMessage & ""
StatusMessage = StatusMessage & ""
StatusMessage = StatusMessage & ""
MsgBox Err.Description & vbCrLf & vbCrLf & "Please contact the Support team. _
This error probably means that source _
file is locked, or that the wrong file _
has been saved here: " & vbCrLf & vbCrLf & _
strPathFull, vbCritical, APP_NAME & ": file data error:"
StatusMessage = "#ERROR " & StatusMessage
ElseIf InStr(Err.Description, "Permission Denied") Then
StatusMessage = StatusMessage & "Cannot open the file: "
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & vbTab & Chr(34) & strPathFull & Chr(34)
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & "Another user probably has this file open. _
Please wait a few minutes, and try again. _
If this error persists, please contact Desktop team."
MsgBox StatusMessage, vbCritical, APP_NAME & ": file access error:"
StatusMessage = "#ERROR " & StatusMessage
Else
StatusMessage = StatusMessage & "#ERROR " & Err.Number & ": " & Err.Description
MsgBox StatusMessage, vbCritical, APP_NAME & ": file data error:"
End If
Resume ExitSub
' # leave this inaccessible statement in place for debugging:
Resume
End Function
Apologies if you run into problems with line breaks around the '_' split lines.
You'll also need declarations for the Constant 'APP_NAME':
PUBLIC CONST APP_NAME As String = "SQL Bluescreen demonstrator"
And a VBA API declaration for the 'Sleep' function:
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows: PtrSafe declarations and LongLong
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#ElseIf VBA7 Then ' VBA7 in a 32-bit environment: PtrSafe declarations, but no LongLong
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else ' 32 bit Excel
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Running SQL against Microsoft Excel is best regarded as A Bad Thing: yes, SQL is by far the best tool for large volumes of tabulated data; but no, Microsoft aren't going to fix those memory leaks any time soon. No-one in Redmond is interested in what you are trying to do there - not when you could buy a copy of MS-Access or SQL server andport your data over.
However, it's still the least-worst solution when you're not going to get a SQL Server of your own and you've got a large volume of data in someone else's spreadsheet. Or spreadsheets, plural.
So here's a Horrible Hack to read Excel with SQL.
The subheading to that article reads:
A Cautionary Tale of things that no developer should ever see or do, with diversions and digressions into failures of business logic, workarounds and worse-arounds, budget fairies, business analysts, and scrofulous pilgrims seeking miraculous healing in the elevator lobby.
...and you should treat that as a warning of what you're in for: a long and bitter code-wrangling, to do something that you probably should've done some other way.
Magic! Send the .xlsm attached to an email. Send email to yourself and download the attachment. Launch, enable content received by Internet, enable macro execution. Problem disappeared.
I want to monitor a drive for file changes, using VBScript. I have the below code. It works fine for InstanceCreationEvent and InstanceDeletionEvent. But InstanceModificationEvent is not happening. From googling I got to know we need to use CIM_DataFile instead of CIM_DirectoryContainsFile to monitor InstanceModificationEvent. I am not sure how to modify the code. Can anyone help.
FYI: One script should monitor all the folders and subfolders in a drive.
PS: Any suggestion to improve the code and performance or other ideas also welcome.
My Code:
Dim arrFolders
Dim strComputer
Dim objWMIService
Dim strFolder
Dim strCommand
Dim i
Dim strQuery
strChangeFile = "MonitorFolder_Log.txt"
strMailIDFile = "MonitorFolder_MailIDs.txt"
'Check if the log file exists, if not ceate a new file and exit the script. Restart the script again.
Set oFSO = CreateObject("Scripting.FileSystemObject")
If not oFSO.FileExists(strChangeFile) then
'WScript.Echo "Change Log File Not Found. Creating new file..."
Set oTxtFile = oFSO.CreateTextFile(strChangeFile)
WScript.Echo strChangeFile & " File Created." & vbCrLf & "Please restart the script." & vbCrLf
WScript.Quit
End If
'Prompt for which drive should be monitored. If not a valid drive, then exit the script.
strDrive = InputBox("Enter the drive to monitor: " & vbCrLf & "E.g.: Input C to monitor C:\ drive.", "Monitor Folder - Oracle", "E")
If strDrive = "" then
WScript.Echo "Not a valid drive. Terminating the script."
WScript.Quit
End If
'Append ":" with the drive name.
strDrive = strDrive & ":"
'Read the mail IDs.
Set objFSOMailID = CreateObject("Scripting.FileSystemObject")
Set oTSMailID = objFSOMailID.OpenTextFile(strMailIDFile)
strMailIDsList = oTSMailID.ReadAll
oTSMailID.close
'WScript.Echo strMailIDsList
'Array to store the existing folder paths that should be monitored.
arrFolders = Array()
i = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubfolders FSO.GetFolder(strDrive)
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
i = i + 1
folderPath = "" & Subfolder.Path & ""
folderPath = Replace(folderPath ,"\","\\\\")
ReDim Preserve arrFolders(i)
arrFolders(i) = folderPath
'Wscript.Echo i & " " & arrFolders(i)
ShowSubFolders Subfolder
Next
End Sub
'Set the first path to be the drive.
arrFolders(0) = strDrive & "\\\\"
'Use WMI query to get the file changes.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
'WScript.Echo "setup for folder: " & strFolder & vbLf
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * " _
& "FROM __InstanceOperationEvent " _
& "WITHIN 1 " _
& "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" _
& " AND TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & vbLf _
& " 'Wscript.Echo objObject.TargetInstance.PartComponent" & vbLf _
& " SendNotification(objObject)" & vbLf _
& "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
'Wait for events.
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Function SendNotification(objObject)
strEventType = objObject.Path_.Class
strPartComp = Split(objObject.TargetInstance.PartComponent, "=")
strFileName = Replace(strPartComp(1), "\\", "\")
WScript.Echo strEventType
WScript.Echo strFileName
'Some more code to send mail and logs...
End Function
Monitoring the entire filesystem for file creation is not feasible. It will eat up system resources and might severly affect system operation. Only ever monitor selected folders. The following should work:
Const Interval = 1
Set monitor = CreateMonitor("C:\foo")
Do
Set evt = monitor.NextEvent()
Select Case evt.Path_.Class
Case "__InstanceCreationEvent" : SendNotification evt.TargetInstance
Case "__InstanceModificationEvent" : ...
Case "__InstanceDeletionEvent" : ...
End Select
Loop
Function CreateMonitor(path)
Set wmi = GetObject("winmgmts://./root/cimv2")
Set fso = CreateObject("Scripting.FileSystemObject")
path = Split(fso.GetAbsolutePathName(path), ":")
drv = path(0) & ":"
dir = Replace(path(1), "\", "\\")
If Right(dir, 2) <> "\\" Then dir = dir & "\\"
query = "SELECT * FROM __InstanceOperationEvent" & _
" WITHIN " & Interval & _
" WHERE Targetinstance ISA 'CIM_DataFile'" & _
" AND TargetInstance.Drive='" & drv & "'" & _
" AND TargetInstance.Path='" & dir & "'"
Set CreateMonitor = wmi.ExecNotificationQuery(query)
End Function
Sub SendNotification(tgtInst)
'send notification
End Sub
You should run monitors for different folders as separate processes, because NextEvent() is a blocking operation.
I put together some VBA code for Outlook 2007 which has been working predominantly fine.
Its basically designed to check incoming messages and store the subject, body etc into a database and the attachment into a folder. In general, it works fine, but out of 100 messages or so, it drops the odd email.
I previously had a problem where some emails were not being processed and stored in the database, but then discovered there was an issue with illegal characters, which i have solved now, so that cant be it. I've compared the emails being dropped to the one's that arent, in terms of message header, content to and from fields and i cant see any difference between the two emails at all, so am completely perplexed as to why they're being dropped. When i copy the content of the email and forward it back to the system again, the VBA code processes it fine.
I am pasting the code below (the code links to some modules which are used for checking illegal characters or concatenating strings)
Sub SaveIncomingEmails(Items As Outlook.MailItem) ' enable this to run macro inbound emails
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
' ================================================================
' Open a Connection using an ODBC DSN named "Delphi".
' ================================================================
cnn.Open "MyDB", "MyUsername", "MyPassword"
' ================================================================
' Constants declaration
' ================================================================
Const olFolderInbox = 6
Const olTxt = 0
' ================================================================
' variable declaration
' ================================================================
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim SenderName As String
Dim i As Integer
Dim strSQLquery As String
Dim strSQLquery1 As String
Dim strSQLGTDResourceQuery As String
Dim MessageHeader As String
Dim strCommandQuery As String
Dim strGTDIdQuery As String
Dim AttachmentStr As String
Dim strFailedRcp As String
Dim strSubject As String
Dim hasattachment As String
Dim AttachmentType As String
Dim SenderAuthorised As String
Dim strToEmail As String
Dim strFromEmail As String
Dim strBody As String
Dim strSentDate As String
Dim strReceivedDate As String
Dim StrUniqueID As String
Dim strCommandDate As String
Dim strDomain As String
Dim strBodyStripped As String
Dim strSubjectStripped As String
Dim rs As Object
Dim strGoalId As String
Dim strFile As String
Dim strSenderAccountDescription As String
Dim strContentType As String
Dim strMimeVersion As String
Dim strReceived As String
' ================================================================
' Intializing variables
' ================================================================
i = 0
Set objItem = Items
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set colMailItems = objFolder.Items
Set Item = objItem
strToEmail = Items.To
strFromEmail = Items.SenderEmailAddress
strSubject = Items.Subject
strBody = Items.Body
strSentDate = Items.SentOn
strReceivedDate = Items.ReceivedTime
'Initialize variables in a given format
StrUniqueID = Format(Items.ReceivedTime, "ddmmyyyyhhnnss") & Items.SenderEmailAddress
strCommandDate = Format(Items.ReceivedTime, "mm/dd/yyyy_hh:nn:ss")
' Grab the sender domain by stripping the last portion of the email address using the getdomain function
strDomain = Module2.GetDomain(Items.SenderEmailAddress)
' Strip the body of illegal characters and replace with legal characters for insertion into SQL
strBodyStripped = Module3.RemoveIllegalCharacters(Items.Body)
strSubjectStripped = Module4.RemoveIllegalCharacters(Items.Subject)
AttachmentStr = "images/no_attachment.png"
' ================================================================
' ================================================================
' ================================================================
' =====================================================
' Check list of authorised senders for xsCRM commands.
' Populate email addresses here
' =====================================================
If (InStr(strFromEmail, "AuthorisedSender1#email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender2#email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender3#email.com") > 0) Then
SenderAuthorised = "true"
End If
' ======================================================
' ======================================================
' ======================================================
' ================================================================
' check if subject holds a command
' ================================================================
'check to see if email sender is authorised
If SenderAuthorised = "true" Then
' Check if the subject line contains the string xs4crm is true
If InStr(strSubject, "xs4crm") > 0 Then
'If its true then do this
strCommandQuery = "INSERT INTO XSCRMEMAILCOMMAND (" & vbCrLf & _
"FromEmail," & vbCrLf & _
"command," & vbCrLf & _
"date," & vbCrLf & _
"Body" & vbCrLf & _
") VALUES ('" & strFromEmail & "','" & strSubject & "',GETDATE(),'" & strBody & "')"
Set rs = cnn.Execute(strCommandQuery)
'Look for a GTDID string so that we can save data to resources table
If InStr(strSubject, "gtdid=") > 0 Then
'Set the hasattachment variable to zero since we only want to run this loop if there are no attachments
hasattachment = "0"
'Set the variable to 1 so that we that our next if statement can only run if there are no attachments
For Each Atmt In Item.Attachments
hasattachment = "1"
Next Atmt
If hasattachment = "0" Then
'Grab the GTDId so we know which goal this resource belongs too.
strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
'Save data to table
strGTDIdQuery = "INSERT INTO XSCRMGTDRESOURCES (" & vbCrLf & _
"GoalId," & vbCrLf & _
"insertdatetime" & vbCrLf & _
") VALUES ('" & strGoalId & "',GETDATE())"
Set rs = cnn.Execute(strGTDIdQuery)
End If
End If
End If
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Create folders for atttachments
' ================================================================
' Save any attachments found
For Each Atmt In Item.Attachments
AttachmentStr = "images/attachment.png" 'because it has gone into attachment loop the icon is now required.
'Create the subfolder for the attachment if it doesnt exist based on sender domain
Dim fso
Dim fol As String
fol = "c:\OLAttachments\" & strDomain
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' save attachments
' ================================================================
FileName = "C:\OLAttachments\" & strDomain & "\" & _
Format(Item.CreationTime, "ddmmyyyy-") & Items.SenderEmailAddress & "-" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
strFile = Atmt.FileName
strSQLquery1 = "INSERT INTO XSCRMEMAILSATTACHMENTS (" & vbCrLf & _
"FileSavedIn," & vbCrLf & _
"ActualFileName," & vbCrLf & _
"UniqueIdentifier," & vbCrLf & _
"SendersEmail" & vbCrLf & _
") VALUES ('" & FileName & "','" & StrUniqueID & "','" & strFile & "','" & strFromEmail & "')"
Set rs = cnn.Execute(strSQLquery1)
'If there is a GTDCommand, then grab the GTDId so we know which goal this resource belongs too.
If InStr(strSubject, "gtdid=") > 0 Then
strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
End If
AttachmentType = ""
'If the attachment is png or jpg set attachment type string to image
If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Then
AttachmentType = "image"
End If
'If attachment is .mov set attachment type string to video
If InStr(Atmt.FileName, ".mov") > 0 Then
AttachmentType = "video"
End If
'If the attachment is mp3 or m4a set attachment type string to audio
If (InStr(Atmt.FileName, ".mp3") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Then
AttachmentType = "audio"
End If
'check to see if email sender is authorised
If SenderAuthorised = "true" Then
'If attachment type is an image, audio or video as per extensions above then populate the xscrmgtdresource table with following fields
If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Or (InStr(Atmt.FileName, ".mov") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Or (InStr(Atmt.FileName, ".mp3") > 0) Then
strSQLGTDResourceQuery = "INSERT INTO XSCRMGTDRESOURCES (" & vbCrLf & _
"GoalId," & vbCrLf & _
"Title," & vbCrLf & _
"Type," & vbCrLf & _
"insertdatetime," & vbCrLf & _
"ResourcePath," & vbCrLf & _
"UniqueIdentifier" & vbCrLf & _
") VALUES ('" & strGoalId & "','" & Atmt.FileName & "','" & AttachmentType & "',GETDATE(),'" & FileName & "','" & StrUniqueID & "')"
End If
Set rs = cnn.Execute(strSQLGTDResourceQuery)
End If
Next Atmt
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Setting up to work with the Email Message Header
' ================================================================
'This accesses the message header property and sets the variable MessageHeader
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
MessageHeader = objItem.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
If MessageHeader <> "" Then
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Accessing the message header and collecting specific info for database tables
' ================================================================
strSenderAccountDescription = Module5.GetHeaderProperty(MessageHeader, "From:", "<", 5)
strContentType = Module5.GetHeaderProperty(MessageHeader, "Content-Type:", ";", 13)
strMimeVersion = Module5.GetHeaderProperty(MessageHeader, "MIME-Version:", vbNewLine, 13)
strReceived = Module5.GetHeaderProperty(MessageHeader, "Received:", "(", 9)
'As the x-failed-recipients property does not appear in ALL messageheaders, we have to first check if it is present
If InStr(MessageHeader, "X-Failed-Recipients:") > 0 Then
'Get the MessageHeader Property value
strFailedRcp = Module5.GetHeaderProperty(MessageHeader, "X-Failed-Recipients:", vbNewLine, 20)
'Else set the variable value to blank so that we still have something to supply to the SQL query
Else
strFailedRcp = ""
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Save Email into the database DeplphiDude and table xsCRMEmails for attachment based emails and without attachments
' ================================================================
If InStr(strSubject, "xs4crm") = 0 Then 'only insert if the emails is not a command
strSQLquery = "INSERT INTO XSCRMEMAILS (" & vbCrLf & _
"XFailedRecipients," & vbCrLf & _
"Received," & vbCrLf & _
"MimeVersion," & vbCrLf & _
"ContentType," & vbCrLf & _
"SendersAccountDescription," & vbCrLf & _
"FromEmail," & vbCrLf & _
"ToEmail," & vbCrLf & _
"Subject," & vbCrLf & _
"Body," & vbCrLf & _
"SentDate," & vbCrLf & _
"ReceivedDate," & vbCrLf & _
"UniqueIdentifier," & vbCrLf & _
"Status," & vbCrLf & _
"AttachmentIcon," & vbCrLf & _
"AssignedToUser," & vbCrLf & _
"EmailHeader" & vbCrLf & _
") VALUES ('" & strFailedRcp & "','" & strReceived & "','" & strMimeVersion & "','" & strContentType & "','" & strSenderAccountDescription & "', '" & strFromEmail & "','" & strToEmail & "','" & strSubjectStripped & "','" & strBodyStripped & "','" & strSentDate & "','" & strReceivedDate & "','" & StrUniqueID & "','EmailStatus_New','" & AttachmentStr & "','','" & Module4.RemoveIllegalCharacters(MessageHeader) & "')"
Set rs = cnn.Execute(strSQLquery)
End If
' ================================================================
' final steps
' ================================================================
'Delete email
objItem.Delete
Set objItem = Nothing
Set Atmt = Nothing
' ================================================================
' close connection to the sql server and end the program
' ================================================================
cnn.Close
End Sub
You should add some logging to help track down the problem.
I haven't used this personally, but maybe give it a go: Log4VBA
Also, you should add error handling:
Error Handling and Debugging Tips for Access 2007, VB, and VBA
Error Handling In VBA
First you do not say which part of your process is not working. You have showed a routine that does not fire by itself, it must be called by something else. This something else must have some conditions attached to it to call your routine. What are they? Can you show the workings of this.
If you are using a rule then could you show the conditions of the rule. Further what about if instead of a rule we code for the event in the VBEditor so that you can maybe see this event happening as well? Here is what I am talking about and there is example code there on how to do it MSDN Application_New_MAIL
Next I agree with everyone else that you need some logging, there is so much going on and it is impossible to tell where you cod is falling over. If I were you I would get an email that does not work and send it to yourself and have a break point right at the beginning of your code so that you can see a. That your code is actually being called and then where it is failing.