VBA to Outlook 2015: use plain strings! Method Subject of object OutlookMessage failed

In an Access form we have

dim outlookApp as object

set outlookApp = createobject(“Outlook.Application”)

dim outlookMessage as object

set outlookMessage = outlookApp.CreateObject(0) ‘message

outlookMessage.Subject = me.txtSubject ‘FAIL

‘HOWEVER

outlookMessage.Subject = “” & me.txtSubject

‘WORKS FINE

ok me.txtSubject is an object but prior to Outlook 2015 it was converted to a string for the Subject and To properties.

“” & me.txtSubject is a string that you can use safely.

Access VBA: Dir and Redim surprises

I’ve used Access VBA for years and thought I knew how these subs worked.

Sub WTFDir()
    ‘say you have a file f:\junk.txt
    Debug.Print Dir("f:\junk.txt", vbNormal) ‘file, right?
    Debug.Print Dir("f:\*.*", vbNormal) ‘file, right?
    Debug.Print Dir("f:\someunlikelyfilename.zzx", vbNormal) ’empty string, right?
    Debug.Print Dir("f:\", vbNormal) ’empty string, right? WRONG
    Debug.Print Dir("f:\*", vbDirectory) ‘name of the first subdirectory
    Debug.Print Dir("f:\", vbDirectory) ‘f:\, right? WRONG. Returns the name of the first subdirectory
End Sub

Dir now assumes a pattern so you cannot use it to confirm that a directory or file name is an exact match.

Sub WTFArray()
    Dim a As Variant
    a = Split("a,b,c", ",")
    Debug.Print a(0) ‘a, right?
    ReDim Preserve a(1 To 2)
    Debug.Print a(1) ‘b, right? WRONG
End Sub

Redim Preserve when changing the lower bound of the array changes the indexes of the data in the array. OK i’ve never used this before, maybe this was how it always worked.

You can’t use Redim Preserve to chop off the lower X values of an array.

Remove rows from Excel range based on exclude list

This VBA macro deletes items from a list if they appear in a different list.

For example, if you had a table of data and wanted to take out EAN005 and EAN006

Run the macro. The user is prompted for Range A (A2:C9) and the Excluded Range (E2:E3).

The keyfield has to be the first column.

Rows are removed by moving everything up cell-by-cell so it is very inefficient for long lists or where many rows are to be removed.

Only the content of the cells is moved: if the cell was formatted that formatting stays where it was.

If there are formulas in the table that refer to other cells these will certainly break.

Not selling this one very well, am I? However it’s here and it’s free.

Option Explicit
Sub excludeRange()
    ‘by Nick nick@flikk.net
    ‘When this macro runs it prompts the user for the target range and the exclusion range
    ‘you must select the Range WITHOUT THE HEADERS. The key field / EAN number must be the first column.
    ‘The Exclusion range only needs to have the key field / EAN number
    ‘if the key field / EAN / first column is in the exclusion range, this row is removed.
    ‘the removal happens by copying up all the rows below
    ‘so you can have the target range and exclusion range on one worksheet
    ‘Rows are removed by moving everything up cell-by-cell so it is very inefficient for long lists or where many rows are to be removed.
    ‘Only the content of the cells is moved: if the cell was formatted that formatting stays where it was.
    ‘If there are formulas in the table that refer to other cells these will certainly break.
   
    Dim targetRange As Range
    Dim excludeRange As Range
    Dim msg As String
   
    msg = "Select Target Range A"
    On Error Resume Next
    Set targetRange = Application.InputBox(msg, Type:=8)
   
    If targetRange Is Nothing Then Exit Sub
   
    msg = "Select Exclusion Range B"
    Set excludeRange = Application.InputBox(msg, Type:=8)
   
    If excludeRange Is Nothing Then Exit Sub
    On Error GoTo 0
   
    Dim r As Integer ‘row in target range
    Dim c As Integer  ‘col in target range
    Dim r1 As Integer ‘row in remainder of target range
    Dim currentEan As String ‘current key value
    Dim er As Integer ‘row in exclusion range
    For r = 1 To targetRange.Rows.Count
        currentEan = targetRange(r, 1).Value
        For er = 1 To excludeRange.Rows.Count
            If excludeRange(er, 1).Value = currentEan Then
                ‘remove this row
                ‘remove it by copying all values up
                For r1 = r To targetRange.Rows.Count – 1
                    For c = 1 To targetRange.Columns.Count
                        targetRange(r1, c).Formula = targetRange(r1 + 1, c).Formula
                    Next
                Next r1
                For c = 1 To targetRange.Columns.Count
                    targetRange(r1, c).Formula = targetRange(r1 + 1, c).Formula
                Next
                r = r – 1
                Exit For
            End If
        Next er
    Next r
   
   
End Sub

Microsoft Access VBA CurrentProject.OpenConnection use SQLOLEDB.1 NOT Microsoft.Access.OLEDB.10.0

I think I knew this… if I had remembered it would have saved a couple of hours out of my life

Sub main()
   
    Dim connectionString As String
   
    ‘DONT USE THIS
    ‘connectionString = "Provider=Microsoft.Access.OLEDB.10.0;
    ‘Data Source=hong;Integrated Security=SSPI;
    ‘Initial Catalog=ChilliJardox;Data Provider=SQLOLEDB.1"
   
    ‘USE THIS CONNECTION STRING
    connectionString = "Provider=SQLOLEDB.1;" & _
        "Data Source=hong;Integrated Security=SSPI;" & _
        "Initial Catalog=ChilliJardox;"
   
    On Error Resume Next
    If CurrentProject.IsConnected = False Then
        CurrentProject.OpenConnection connectionString
    ElseIf CurrentProject.Connection.State <> 1 Then
        CurrentProject.OpenConnection connectionString
    End If
    If Len("" & Error) > 0 Then
        MsgBox Error & " using connection string " & connectionString
    End If
    On Error GoTo 0
   
End Sub

Add logging to your Access ADP

Use this table and code to log the duration of events, for example how long does a form take to load or a query take to run. It automatically logs start, workstation id and (if you call the second sub) end time.

Set global variable gLogginOn to true (e.g. using a checkbox in a settings form) to start logging.

--create this table
CREATE TABLE [dbo].[tblDataLog](
    [LogId] [int] IDENTITY(1,1) 
        NOT NULL primary key,
    [Start] [datetime] default getdate(),
    [Ended] [datetime] NULL,
    [Activity] [nvarchar](50) NULL,
    [Parameters] [nvarchar](250) NULL,
    [Workstation] 
        [nvarchar](50) DEFAULT (host_name())
    )
go

--create this proc:
create proc LogStart  @Activity nvarchar(50), 
    @Parameters nvarchar(250), @LogId int output  as
begin
    insert into dbo.tblDataLog 
        (Activity, Parameters) 
        values 
        (@Activity,@Parameters)
    set @LogId= SCOPE_IDENTITY()
End

select * from tbldatalog

 

Option Compare Database
Option Explicit
Global gLoggingOn As Boolean
Global gLogProc As ADODB.Command
Global gEndLogProc As ADODB.Command

Public Function LogStart _
    (Activity As String, parameters As String) As Long

    If Not gLoggingOn Then Exit Function
    Dim logId As Variant
    Dim cmd As ADODB.Command
    If gLogProc Is Nothing Then
        Set gLogProc = New ADODB.Command
        gLogProc.CommandText = "LogStart"
        gLogProc.CommandType = adCmdStoredProc
        gLogProc.ActiveConnection = CurrentProject.Connection
        gLogProc.parameters.Append _
            gLogProc.CreateParameter("Activity", _
            adVarChar, adParamInput, 50)
        gLogProc.parameters.Append _
            gLogProc.CreateParameter("Parameters", _
            adVarChar, adParamInput, 250)
        gLogProc.parameters.Append _
            gLogProc.CreateParameter("LogId", _
            adInteger, adParamOutput)
        
        Set gEndLogProc = New ADODB.Command
        gEndLogProc.CommandText = _
            "update tblDataLog set Ended=getdate() where LogID=?"
        gEndLogProc.CommandType = adCmdText
        gEndLogProc.ActiveConnection = CurrentProject.Connection
        gEndLogProc.parameters.Append _
            gEndLogProc.CreateParameter("p1", _
            adInteger, adParamInput)
    End If
    
    gLogProc.Execute 0, Array(Activity, parameters)
    
    LogStart = gLogProc.parameters("LogId").Value
    
End Function

Public Sub LogEnd(logId As Long)
    If Not gLoggingOn Then Exit Sub
    gEndLogProc.Execute 0, Array(logId)
End Sub

Public Sub TestLogStart()
Dim logId As Long
gLoggingOn = True
    logId = LogStart("test 1", "params")
    Dim i As Long
    For i = 1 To 10000
        DoEvents
    Next
    LogEnd logId
    
    
    
End Sub

Remove blank lines in Access reports (e.g. addresses)

MS Access report controls have CanGrow and CanShrink properties, but these will not shrink a blank line (e.g. in an address) to zero.

This function takes any number of address lines, takes out any blanks, and separates them with VbCrLf (new line).

Public Function TrimAddress(ParamArray lines() As Variant) As String
    Dim ret As String
    Dim s As Variant
    For Each s In lines
        If Len("" & s) > 0 Then
            If Len(ret) > 0 Then ret = ret & vbCrLf
            ret = ret & s
        End If
    Next
    TrimAddress = ret
End Function

Public Sub TestTrimAddress()
    Dim expected As String
    Dim actual As String
    actual = TrimAddress("42 Main Street", "Exmouth", Null, "EX8 777", "")
    expected = "42 Main Street" & vbCrLf & "Exmouth" & vbCrLf & "EX8 777"
    If actual <> expected Then
        MsgBox "TrimAddress did not work: expected " & _
            expected & " actual " & actual
    End If
End Sub

To use it, create a text box on your report and set the ControlSource to the following:

=TrimAddress([CompanyName],[Address1],[Address2],[Address3],[Postcode],[Country])

The result looks a bit like the following. Hope this helps!

DumpRsToCSVStringWithBenefits: VBA to create a CSV string with added columns

You’re using Access to produce a Word mailmerge from the current records in your form.

You now want to add some additional information, say a field, that isn’t in your recordset.

Well you COULD change the recordset and add a calculated column. Drat, only just thought of that.

OR you can use this function to get your recordset as a CSV string and add any additional data or constant values.

Then save this CSV as a file. Then use the very complicated Word VBA function to fire up a Word Merge, or open the CSV in Excel.

Hope it helps someone!

Public Function dumpRsToCSVStringWithBenefits(rs As ADODB.Recordset, arr As Variant)
    ‘create a CSV string from a recordset
    ‘optionally add an array of extra columns
    ‘handy if you are mailmerging to Word from a recordset and want to add a named column to each row
    ‘eg to add a column "SuggestedSurveyDate"
    ‘make your array
    ‘redim arr(0 to 1, 0 to 0)
    ‘arr(0,0)="SuggestedSurveyDate"
    ‘arr(1,0)="Next Friday"
    Dim i As Integer
    Dim j As Integer ‘row number in arr
    Dim s As String
    For i = 0 To rs.Fields.Count – 1
        s = s & rs.Fields(i).Name & ","
    Next
    If IsArray(arr) Then
        j = 0
        For i = 0 To UBound(arr, 2)
            s = s & arr(j, i) & ","
        Next i
        j = j + 1
    End If
    s = s & vbCrLf
    Do While Not rs.EOF
        For i = 0 To rs.Fields.Count – 1
            s = s & """" & rs.Fields(i) & ""","
        Next
        rs.MoveNext
        If IsArray(arr) Then
            For i = 0 To UBound(arr, 2)
                s = s & arr(j, i) & ","
            Next i
            j = j + 1
            If j > UBound(arr, 1) Then j = UBound(arr, 1)
        End If
        s = s & vbCrLf
    Loop
    dumpRsToCSVStringWithBenefits = s
End Function

Public Sub TestDumpRsToCsvStringWithBenefits()
    ReDim arr(0 To 5, 0 To 2)
    Dim rs As ADODB.Recordset
    Dim sql As String
    Dim str As String
    Dim j As Integer
   
    arr(0, 0) = "A"
    arr(0, 1) = "B"
    arr(0, 2) = "C"
    For j = 1 To UBound(arr, 1) ‘2 refers to the second array index
        arr(j, 0) = "A" & j
        arr(j, 1) = "B" & j
        arr(j, 2) = "C" & j
    Next j
   
    sql = "select top 7 PropertyId, Address1 from Property"
    Set rs = CurrentProject.Connection.Execute(sql)
    str = dumpRsToCSVStringWithBenefits(rs, arr)
   
    Debug.Print str
   
End Sub

 

Trim all cells in an Excel workbook

Create this VBA sub and press F5.

‘trim all
Public Sub TrimAll()
    Dim rng As Range
    Dim cel As Range
   
    Set rng = Application.Selection.Worksheet.cells

‘select the whole worksheet that you’re currently in
   
    Set rng = rng.SpecialCells(xlCellTypeConstants)

‘but only contstant value cells
   
    ‘Debug.Print rng.Count
   
    For Each cel In rng
        cel.Value = Trim(cel.Value)
       
    Next
   
End Sub

 

See also: http://msdn.microsoft.com/en-us/library/office/aa213567(v=office.11).aspx

http://stackoverflow.com/questions/821364/selecting-non-blank-cells-in-excel-with-vba

 

Send data from Access to Excel then re-import later

You can send-say- one record from your Access database (with SQL or Access back-end data) to Excel. You can then email the Excel file to a supplier for them to fill in the fields. When they return the file you can re-import it. These code snippets show how you might do this.

You can get a small database containing all the code below from flikkImportExport.zip

Exporting a record

Prompt the user for a template to use. I used my own nOpenFile function:

i = nOpenFile(Me.hwnd, filt, templateName, ft, “xltx”, dialogtitle, “”)

Create an Excel.Application object, get the wb (WorkBook) and ws (WorkSheet) you are going to use.

Set excelApp = CreateObject(“Excel.Application”) ‘every time this runs you get a new Excel app.
‘may be better to store excelApp in global variable and only set it if it’s not set
‘you have to trap for errors in case the user has closed it…
excelApp.Visible = True

If Len(templateName) > 0 And Len(Dir(templateName, vbNormal)) > 0 Then
    Set wb = excelApp.Workbooks.Add(Template:=templateName)
Else
    Set wb = excelApp.Workbooks.Add()
End If

Set ws = wb.Worksheets(1)

 

Look for range “data_here” which should be defined in the template you used. If you didn’t use a template, start the data in B1.

Set theRange = wb.Worksheets(1).range(“b1”)
    On Error Resume Next
    Set theRange = wb.Names(“data_here”).RefersToRange
    On Error GoTo 0

‘for every field in the recordset / record
For col = 0 To rs.Fields.Count – 1
    ‘get the fieldname
    fieldName = rs.Fields(col).Name ‘name of recordset field
    ‘put that into cell A1
    ws.Cells(r, c – 1).Formula = fieldName ‘label cell
    ‘put the value of the recordset field into cell B1
    ws.Cells(r, c).Formula = “=””” & rs.Fields(col).Value & “””” ‘value cell
    ‘name the range B1 the same as the fieldname
    wb.Names.Add Name:=fieldName, RefersToR1C1:=”=” & ws.Name & “!R” & r & “C” & c ‘name the value cell
    ‘on to the next row
    r = r + 1
Next

Now you have a spreadsheet / worksheet with two columns: A is the field names and B is the field values. Each cell in B is also a named range, the name being the field name.

My spreadsheet looks like this…

Send this to the suppliers and ask them to fill in the fields. If you dont’ want them to see fields, just delete those rows, together with the named ranges. You can of course alter the code so these fields don’t see the light of day.

Some time later, the spreadsheet comes back.

Press the Import button. This code runs…

Set rs = Me.Recordset

filt = “Excel Files|*.xl*|All Files|*.*”
dialogtitle = “Select incoming spreadsheet”
   
i = nOpenFile(Me.hwnd, filt, fileName, ft, “xlsx”, dialogtitle, “”)

If Len(fileName) > 0 And Len(Dir(fileName, vbNormal)) > 0 Then
    Set excelApp = CreateObject(“Excel.Application”) ‘every time this runs you get a new Excel app.
    ‘may be better to store excelApp in global variable and only set it if it’s not set
    ‘you have to trap for errors in case the user has closed it…
    excelApp.Visible = True
   
    Set wb = excelApp.Workbooks.Open(fileName)

Now wb is the workbook to import. It has a set of Names and these correspond with the fieldnames in your table.

One field contains your primary key. You can find the value of that as follows…

‘todo: make this suit your own data
‘find the named PRODUCTID, then choose that record to edit
fieldName = “ProductId”
Dim ProductID As Long
ProductID = wb.Names(fieldName).RefersToRange.Value2
‘productId should be the ID you want to edit

 

If you’ve got the primary key, you can find the relevant record…

If (ProductID > 0) Then
    rs.FindFirst (“ProductID=” & ProductID)
    If rs.NoMatch Then
    Else

Now you can edit the fields one-by-one

rs.Edit ‘TODO: this is only necessary for a DAO Recordset
For i = 1 To wb.Names.Count
   fieldName = wb.Names(i).Name
   ‘todo: ignore fieldNames you can’t update
   Select Case fieldName
   Case “data_here”
      ‘do nothing
   Case Else
      On Error Resume Next
      rs(fieldName).Value = wb.Names(fieldName).RefersToRange.Value2
      On Error GoTo 0
   End Select
Next

Access / Excel VBA proc to calculate distance using Google Maps

You can slot in this sub to calculate the distance between two points.

Don’t call it for industrial numbers of points or you’ll get throttled… if you can, put it through as one request with waypoints.

Public Sub GoogleGetDistance(ByVal startFrom As String, ByVal endAt As String, ByRef refDistance As Double, ByRef refTime As Date)
    Dim url As String
    refDistance = -1
    refTime = 0
    url = “http://maps.googleapis.com/maps/api/directions/xml?”
    url = url & “origin=” & startFrom & “&”
    url = url & “destination=” & endAt & “&”
   
    url = url & “optimize:false&”
    url = url & “sensor=false&region=uk”
   
    ‘MsgBox url
   
    If Len(Dir(“temproute.xml”, vbNormal)) > 0 Then Kill “temproute.xml”
    ‘AppendToFile “temproute.xml”, url
   
    ‘Shell “notepad temproute.xml”, vbNormalFocus
   
    Dim req As MSXML2.XMLHTTP
    Set req = New MSXML2.XMLHTTP
    req.Open “GET”, url, False
    req.send
   
    Dim resp As String
    resp = req.responseText
   
    Dim xdoc As MSXML2.DOMDocument
    Set xdoc = req.responseXML
   
    xdoc.Save “temprouteresult.xml”
    ‘Shell “notepad temprouteresult.xml”, vbNormalFocus
   
    Dim l As IXMLDOMNode
    Set l = xdoc.selectSingleNode(“DirectionsResponse/route/leg”)
    If Not IsNull(l) Then
        refTime = CLng(l.selectSingleNode(“duration/value”).Text) / 60 / 60 / 24
        refDistance = CLng(Format(CLng(l.selectSingleNode(“distance/value”).Text) / 1609, “0.0”))
    End If
   

End Sub