I am trying to make a macro which copies emails when I receive them, and saves them in specific windows folders on a network drive based on the domain name.
The list of domains I have will be large and subject to change by users without coding experience, so I am looking to develop a text, CSV, or excel file that someone can update which lists my company's relationship to them (client, vendor, sub-contractor, etc...) and their name (both of which controls the file path), the domain name (#example.com).
I think I can figure out how to do most of that (a clever combination of nested if and for statements), but I can't figure out how to read the file into an array, and my google-fu has failed me.
I don't think it really helps, but here is the code that I shamelessly copied from the web and am planning to work off of.
Option Explicit
Private WithEvents InboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
Dim SenderAddress As String
On Error Resume Next
' Define SenderAddress as sender's email address or domain
xFilePath = PathCreator(SenderAddress)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "")
xMailItem.SaveAs xFilePath & "\" & xFileName & ".html", olHTML
End If
Exit Sub
End Sub
Function PathCreator(SenderAddress)
' [needs to read the file and create the path based on the values]
End Function
You can use ADODB to connect to the source file, and read it into a 2-dimensional array. Add a reference to Microsoft ActiveX Data Objects from Tools -> References.... For example, if you want to use an Excel file:
Dim excelPath As String
excelPath = "C:\path\to\excel\file.xlsx" ' Replace with the path to the Excel file
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & excelPath & """;" & _
"Extended Properties=""Excel 12.0;HDR=Yes"""
'This assumes the Excel file contains column headers -- HDR=Yes
Dim sql As String
sql = "SELECT Relationship, LastName, FirstName, DomainName FROM [Sheet1$]"
'Assumes the relevant worksheet is named Sheet1
'Also assumes the first row of the sheet has the following labels: Relationship, LastName, FirstName, Domain (in no particular order)
Dim rs As New ADODB.Recordset
rs.Open sql, connectionString
Dim arr As Variant
arr = rs.GetRows 'Puts the data from the recordset into an array
rs.Close
Set rs = Nothing
Dim row As Variant, column As Variant
For row = 0 To UBound(arr, 2)
For column = 0 To UBound(arr, 1)
Debug.Print arr(column, row)
Next
Next
Using a text file or CSV is just a matter of slightly changing the connection string and the SQL. But I think using an Excel file will force the users to keep the data in columns, where in a CSV users would have to insert field- and row-separators manually; the same for any other text format -- users would have to remember the format's rules and apply them correctly.
But I question if an array is the best data structure for you to use; in this case you could use the recordset directly. In order to make sure the file is not held open, you could use a disconnected recordset. (If your intention is to find the appropriate domain name and use that to get other details, then I would suggest you load the data from a recordset into a Scripting.Dictionary.)
Also note that you probably only need to load the data from the file once, unless you expect it to change while the code is running.
I would write something like this
Dim rs As ADODB.Recordset
Function PathCreator(SenderAddress) As String
If rs Is Nothing Then
Dim excelPath As String
excelPath = "C:\path\to\excel\file.xlsx" ' Replace with the path to the Excel file
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & excelPath & """;" & _
"Extended Properties=""Excel 12.0;HDR=Yes"""
Dim sql As String
sql = "SELECT Relationship, LastName, FirstName, DomainName FROM [Sheet1$]"
Set rs As New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.CursorType = adOpenStatic
rs.Open sql, connectionString, adOpenStatic, adLockBatchOptimistic
'Disconnect the recordset
rs.ActiveConnection = Nothing
'Now the data will still be available as long as the code is running
'But the connection to the Excel file will be closed
End If
'build the path here, using the recordset fields
PathCreator = rs!Relationship & "_" & rs!LastName & "_" & rs!FirstName & "_" & rs!Domain
End Function
NB. By the same token, you can add a reference to Microsoft Scripting Runtime; then you can write the code that uses the FileSystemObject as follows:
Dim FSO As New Scripting.FileSystemObject
If Not FSO.FolderExists(xFilePath) Then
FSO.CreateFolder xFilePath
End If
and with a reference to the Microsoft VBScript Regular Expressions 5.5 libary:
Set xRegEx As New VBScript_RegExp_55.RegExp
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "")
xMailItem.SaveAs xFilePath & "\" & xFileName & ".html", olHTML
End If
Related
I have just inherited a database at my new company. Old DB owner left no good documentation and queries very hard to keep track of. Looking for programmatic answer to track sources of fields in every query (what table it come from). Prefer something can be exported to Excel to study, Access visualization is no good. Am familiar with VBA.
This is pretty messy but could save you time collecting each query's SQL code. The following code exports all SQL stored in the QueryDefs collection into a text file. I have it splitting the code with a space delimiter, but a comma might be preferable. The data will not be normalized, I don't have the time to go to that level of complexity. Just make sure to update strPath before you execute. Hopefully this helps.
Sub PullQuerySQL()
Dim dbs As Database
Dim i As Integer
Dim fso As Object
Dim oFile As Object
Dim varParse() As String
Dim element As Variant
Dim strPath As String
strPath = ".txt"
Set dbs = CurrentDb()
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFile = fso.CreateTextFile(strPath)
For i = 0 To dbs.QueryDefs.Count - 1
oFile.WriteLine dbs.QueryDefs(i).Name
varParse = Split(dbs.QueryDefs(i).SQL, " ")
For Each element In varParse
oFile.WriteLine element
Next element
Next i
oFile.Close
Set oFile = Nothing
Set fso = Nothing
Set dbs = Nothing
End Sub
I have been through this with many inherited databases. I find it extremely helpful to create an Access table with the fields and the tables/queries that they come from. Try this code below. It will prompt you for the name of the query that you are looking to "map" as I call it. It will then create a new table named "queryName Definitions".
Option Compare Database
Public Sub MapQuery()
Dim strQueryName As String
Dim rst As DAO.Recordset
Dim fld As Field
Dim strSource As String
Dim strField As String
Dim strValue As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim booExists As Boolean
strQueryName = InputBox("Please enter the name of the query that you are looking to map")
Set rst = CurrentDb.OpenRecordset(strQueryName)
On Error GoTo error1
booExists = IsObject(CurrentDb.TableDefs(strQueryName & " Definitions"))
DoCmd.DeleteObject acTable, strQueryName & " Definitions"
continue:
strSQL1 = "CREATE TABLE [" & strQueryName & " Definitions]" & " (FieldName CHAR, SourceName CHAR);"
DoCmd.RunSQL (strSQL1)
DoCmd.SetWarnings False
For Each fld In rst.Fields
strField = fld.Name
strSource = fld.SourceTable
Debug.Print strValue
strSQL2 = "INSERT INTO [" & strQueryName & " Definitions]" & "(FieldName, SourceName) VALUES(""" & strField & """, """ & strSource & """);"
DoCmd.RunSQL (strSQL2)
Next fld
error1:
If Err.Number = 3265 Then
Resume continue
Else
MsgBox Err.Description
End If
DoCmd.SetWarnings True
Exit Sub
DoCmd.SetWarnings True
End Sub
I have a folder with lots (hundreds) of locked .xls files.
I need to copy a specific range from one of the worksheets in each file into one big worksheet, which would be my data file for future analysis.
I tried to write a macro for this, but keep getting errors.
Please help me debug what I wrote:
Sub ProcessFiles()
' declarations & definitions
Dim Pathname As String
Dim Filename As String
Dim sourceWB As Workbook
Dim targetWB As Workbook
targetWB = ActiveWorkbook
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
' loop through all files in folder
Do While Filename <> ""
Set sourceWB = Workbooks.Open(Pathname & Filename)
' unlock worksheets
sourceWB.Sheets(4).Visible = True
sourceWB.Sheets(4).Unprotect Password:="Password"
sourceWB.Sheets(2).Unprotect Password:="Password"
' create new worksheet
sourceWB.Sheets.Add After:=8
' copy required cells to new sheets
sourceWB.Sheets(2).Range("A14:FM663").Copy Destination:=sourceWB.Sheets(9).Range("C2")
' fill columns for all rows
sourceWB.Sheets(9).Range("A2:A663").Value = sourceWB.Name
sourceWB.Sheets(9).Range("B2:B663").Value = Worksheets(4).Range("C13").Value
'move AuxSheet to taget workbook
sourceWB.Sheets(9).Move Before:=Workbooks(targetWB).Sheets(1)
'add to full data worksheet
targetWB.Sheets(1).Range("A2:FO651").Copy Destination:=sourceWB.Sheets(2).Rows("3:" & Worksheets("Sheet2").UsedRange.Rows.Count)
'close file and repeat
sourceWB.Close SaveChanges:=False
Filename = Dir()
Loop
' save result
targetWB.Save
End Sub
Just to give you an idea of how tasks like this can be handled way more efficient... consider the following that I always use for tasks like this:
Option Explicit
' 1. Add reference to Microsoft Scripting Runtime and Access Data Objects Library via Extras>References
Sub ProcessFiles()
Dim strCon As String
Dim strSQL As String
Dim fso As New Scripting.FileSystemObject
Dim myfile As file
With ThisWorkbook
' 2. empty your outputsheet
.Sheets("out").Cells.Clear
' 3. loop the files in your folder
For Each myfile In fso.GetFolder(.Path & Application.PathSeparator & "Files").Files
' 3.1. no proper way to filter files like in Dir(), but we want to use the file objects
If myfile.Name Like "*.xls" Then
' 3.1.1. Construct the connection string, the only variable part is myfile.Path
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myfile.Path & ";Extended Properties='Excel 8.0;HDR=YES';"
' 3.1.2. Construct the SQL String. Luckily, you already know where your data is
strSQL = "SELECT '" & myfile.Name & "' AS WorkbookName, * FROM [sheetData$A1:C5], (SELECT TOP 1 * FROM [sheetSchool$C12:C13])"
' 3.1.3. Call the get-data sub from below
GetData .Sheets("out"), strCon, strSQL
End If
Next myfile
End With
End Sub
Sub GetData(ByRef wsOut As Variant, strCon As String, strSQL As String)
Dim i As Integer
On Error GoTo skpError
Application.ScreenUpdating = False
' Create a new database connection
Dim objCon As New ADODB.Connection
With objCon
.ConnectionString = strCon
.Open
End With
' Create a new database command
Dim objCmd As New ADODB.Command
With objCmd
.ActiveConnection = objCon
.CommandType = adCmdText
.CommandText = strSQL
Debug.Print .CommandText
End With
' Create a new recordset
Dim objRS
Set objRS = New ADODB.Recordset
With objRS
.ActiveConnection = objCon
.Open objCmd
End With
' Print your FieldNames, in case they're not already there
With wsOut
If wsOut.Cells(1, 1).Value = vbNullString Then
For i = 1 To objRS.Fields.Count
.Cells(1, i).Value = _
objRS.Fields(i - 1).Name
Next i
End If
' Output your data - pretty ugly, but reliable
.Range("A1048576").End(xlUp).Offset(1, 0).CopyFromRecordset (objRS)
End With
skpNoError:
Application.ScreenUpdating = True
Exit Sub
skpError:
MsgBox "Error #" & Err & vbNewLine & Error, vbCritical
GoTo skpNoError
End Sub
Notes: (why use something like this?)
protected and hidden worksheets shouldn't be a problem with this. For protected workbooks, a password parameter can be added to the connection string
this will be considerably faster for a large number of files than opening, editing, copying would be. If you feel fancy, you can further speed things up by moving stuff from the GetData-Sub to ProcessFiles, so they won't get called repeatedly.
you use a database language for querying data instead of some clumsy copy/paste mechanism.
Edit:
Edited my code, for me this works with the example you gave.
From what i gather, you only got protected Worksheets, not a password-protected Workbook - therefore there's no need to unhide or unprotect your worksheets
adjust the line strSQL = "SELECT '" & myfile.Name & "' AS WorkbookName, * FROM [sheetData$A1:C5], (SELECT TOP 1 * FROM [sheetSchool$C12:C13])" to contain your actual Sheets(2) and Sheets(4) names
I'm using a Excel macro to transfer data between works with ADO by following these guidelines. Currently, I've set up the code to search for a keyword in column A of the source file. Once it finds the keyword, it will copy data from that entire row. However, I only need data from columns G-I, and cannot find the information to condense the data selection.
Public Sub MoveData()
'defines the project name as a variable
Dim fileName As String
fileName = Worksheets("Cover").Range("B5").Value
'defines the path
Dim path As String
path = "C:\Users\(user)\Documents\(folder)\" & fileName & ".csv"
'defines the two workbooks that the data will move between
Dim currentWB As Workbook
Set currentWB = ThisWorkbook
Dim openWB As Workbook
Set openWB = Workbooks.Open(path)
Dim openWs As Worksheet
Set openWs = openWB.Sheets(fileName)
'connects using ADODB to transfer the data
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & path & ";" & _
"Extended Properties=Excel 12.0 Xml;"
.Open
End With
'selects the first column to be read and sorted
Dim subCell As Range
Dim myRange As Range
Set myRange = Range("A1:A500")
Dim cmdOpen As Boolean
cmdOpen = False
For Each subCell In myRange
'searches for the column markups
If subCell Like "*COLUMN*" Then
strQuery = "SELECT * FROM [" & fileName & "$] Where Subject = '" & subCell.Value & "'"
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cn
.CommandText = strQuery
End With
Dim rst As New ADODB.Recordset
With rst
If cmdOpen = False Then
.Open cmd
cmdOpen = True
End If
End With
currentWB.Worksheets("Cols").Range("B7:D7").CopyFromRecordset rst
End If
Next subCell
openWB.Close
End Sub
This strQuery = "SELECT * FROM [" & fileName & "$] Where Subject = '" & subCell.Value & "'" is the line I am referring to. It selects the row of data where the keyword is found. I want to limit this selection to columns G-I. Any advice on how I could accomplish this would be greatly appreciated.
I am using VBA in Visual Studio Express. What I am trying to do is give the top row of my excel spreedsheet that i have created by exporting an MS Access DB through VB, column names, i.e. the names that i have in my DB.
There are 10 columns the 9th is skipped, i have also spaced the spreedsheet out to allow for the first row to have headers, how would i fill the first row of my spreedsheet with the column names of my DB?
Also it is fine if to assign the names directly through the code rather than passing the column headers from the DB as well.
My Code:
Public Sub ExportEx()
Dim strSQL_Query As String
Dim oCN As ADODB.Connection
Dim oCMD As ADODB.Command
Dim oRecords As ADODB.Recordset
Dim strDBPath As String
Dim varValues As Object
Dim lngRows As Long
Dim lngCols As Long
Dim strCN As String
strDBPath = Application.StartupPath & "\SCO_Leaderboard.accdb"
strCN = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDBPath & ";" & _
"Persist Security Info=False;"
strSQL_Query = "Select top 10 Rank, Username, Time_Played, Lv, EXP, Floor, Col, Logins, Status FROM tblUsers ORDER BY Rank ASC"
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
oExcel = CreateObject("Excel.Application")
oBook = oExcel.Workbooks.Add
oSheet = oBook.Worksheets(1)
oCN = New ADODB.Connection
oCN.ConnectionString = strCN
oCN.Open()
oCMD = New ADODB.Command
oCMD.ActiveConnection = oCN
oCMD.CommandText = strSQL_Query
oRecords = oCMD.Execute
varValues = oRecords.GetRows
lngCols = UBound(varValues, 2)
lngRows = UBound(varValues, 1)
oSheet.Range("A2", oSheet.Range("A2").Offset(lngRows, lngCols)) = varValues
oBook.SaveAs(Application.StartupPath & "\Top_10_All_Time.xls")
oExcel.Quit()
MsgBox("An Excel spreadsheet has been created under:" & vbNewLine & vbNewLine & Application.StartupPath & "\Top_10_All_Time.xls")
'' Clean up...
oCMD = Nothing
oCN.Close()
oCN = Nothing
On another note how would I space the fields out in Excel so that all the data fit in the column?
Thanks for any help,
Andy
In VBA, there are two methods to exporting Access table/query data to an Excel spreadsheet:
1) TransferSpreadsheet method
This command will export all fields and records. So, save your VBA string as a stored query object and reference it in below command:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
"yourtableorqueryname", "fullpathtoExcelFile", True
2) CopyFromRecordset method
This command will export only records. However, you can use the recordset's Fields property to fill in first row. Do note the code below assumes you create an ADO recordset named rst using your ADODB connection.
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
rst = "Select top 10 Rank, Username, Time_Played, Lv, EXP, Floor, Col, Logins, Status" _
& " FROM tblUsers ORDER BY Rank ASC", oCN
oSheet.Range("A1").Select
For Each fld In rst.Fields
oExcel.ActiveCell = fld.Name
oExcel.ActiveCell.Offset(0, 1).Select
Next
'REMOVE BELOW IF YOU WANT ONLY COLUMN HEADERS NOT DATA
oSheet.Range("A2").CopyFromRecordset rst
'TO AUTO FIT (SPACE OUT) COLUMNS
osheet.Range("A1:I" & rst.RecordCount + 1).Columns.AutoFit
This works in Access, I am not sure if it works in your case:
Select top 10 Rank As Header1, Username As Header2, Time_Played As Header3 ...
You would have to retrieve the fields Collection from the scheam of oRecords:
oRecords = oCMD.Execute
or just parse the field names from strSQL ...
or - very easy, as you define the field names and build your SQL from the field names - put these in an array and then build the first row of your range from this array.
After this question: get value/charts in another workbooks without opening it
I have coded this:
Sub test()
Dim oConn As New ADODB.Connection
Dim rst As New ADODB.Recordset
oConn.Provider = "Microsoft.Jet.OLEDB.4.0"
oConn.Properties("Extended Properties").Value = "Excel 8.0"
oConn.Open "C:\Workbook1.xlsm"
rst.Open "SELECT * FROM [A1:A2];", oConn, adOpenStatic
rst.MoveFirst
MsgBox rst.Fields(0)
rst.Close
oConn.Close
End Sub
For the moment my goal is to get the value in the cell A1 of the sheet 1 of workbook1.xlsm.
I've encountered two problems.
When the workbook1 is not opened I got a
Run time error '-214767259 (80004005)': Automation error Unspecified Error on the line oConn.Open "C:\Workbook1.xlsm`
This is annoying because I want to work without opening the workbooks. It works well when the workbook is open.
Second problem: I can't manage to only get a single cell value. I've tried to input only [A1] in rst.open but it doesn't work. How can I get a unique cell value with its address ? with its name ?
If you don't mind I'll provide you a bit different attempt to get your data. The difference is the way you connect with you database (excel sheet). However, you could possibly incorporate some important elements into your code. So, check comments inside the code below.
Sub Closed_excel_workbook()
Dim myConnection As String
Dim myRecordset As ADODB.Recordset
Dim mySQL As String
'connection string parameters
'CHANGE PATH TO YOUR CLOSED WORKBOOK
myConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\Dane\BazaDanych.xlsx;" & _
"Extended Properties=Excel 12.0"
'here is important, YOU CAN'T MISS SHEET NAME
mySQL = "SELECT * FROM [ARKUSZ1$a1:a2]"
'different way of getting data from excel sheet
Set myRecordset = New ADODB.Recordset
myRecordset.Open mySQL, myConnection, adOpenUnspecified, adLockUnspecified
'let's clear sheet before pasting data
'REMOVE IF NOT NEEDED
ActiveSheet.Cells.Clear
'HERE WE PASTING DATA WE HAVE RETRIEVED
ActiveSheet.Range("A2").CopyFromRecordset myRecordset
'OPTIONAL, IF REQUIRED YOU CAN ADD COLUMNS NAMES
Dim cell As Range, i!
With ActiveSheet.Range("A1").CurrentRegion
For i = 0 To myRecordset.Fields.Count - 1
.Cells(1, i + 1).Value = myRecordset.Fields(i).Name
Next i
.EntireColumn.AutoFit
End With
End Sub
My solution:
Function GetValue()
Path = "C:\Path\"
File = "Doc.xlsm"
Sheet = "Sheet_name"
Ref = "D4"
'Retrieves a value from a closed workbook
Dim Arg As String
'Make sure the file exists
If Right(Path, 1) <> "\" Then Path = Path & "\"
If Dir(Path & File) = "" Then
GetValue = "File not Found"
Exit Function
End If
'Create the argument
Arg = "'" & Path & "[" & File & "]" & CStr(Sheet) & "'!" & Range(Ref).Range("A1").Address(, , xlR1C1)
'Check the value
MsgBox Arg
'Execute XML
GetValue = ExecuteExcel4Macro(Arg)
End Function
It has the advantage of not using complex adodb connection, but may be less powerfull.