Alternate way of sending email from Outlook to OneNote - vba

I've scoured the internet to find an answer, but was unable to find an answer. Here is my problem:
My organisation has a size limitation in Outlook 2013 inbox size. As such, we have had to come up with possible solutions to saving these emails in a comprehesive way which is easy to manage and easy to find way.
I've heard that we could possibly automatically send our emails directly to OneNote 2013. I've used the "send to OneNote" button in Outlook, however I was wondering if anyone has any better solution that could automatically create a section named the email sender's name if it does not exist and copy the email to a new page.
The only VBA code I have found in my searches is to either create a OneNote page or search, however my very limited knowledge in XML does not allow me to go further.
Can anyone point me in the right direction?
Here is some of the code I've found:
Option Explicit
Sub CreateNewPage()
' Connect to OneNote 2010.
' To see the results of the code,
' you'll want to ensure the OneNote 2010 user
' interface is visible.
Dim OneNote As OneNote.Application
Set OneNote = New OneNote.Application
' Get all of the Notebook nodes.
Dim nodes As MSXML2.IXMLDOMNodeList
Set nodes = GetFirstOneNoteNotebookNodes(OneNote)
If Not nodes Is Nothing Then
' Get the first OneNote Notebook in the XML document.
Dim node As MSXML2.IXMLDOMNode
Set node = nodes(2)
Dim noteBookName As String
noteBookName = node.Attributes.getNamedItem("name").Text
' Get the ID for the Notebook so the code can retrieve
' the list of sections.
Dim notebookID As String
notebookID = node.Attributes.getNamedItem("ID").Text
' Load the XML for the Sections for the Notebook requested.
Dim sectionsXml As String
OneNote.GetHierarchy notebookID, hsSections, sectionsXml, xs2013
' Dim a As MSXML2.DOMDocument60
Dim secDoc As MSXML2.DOMDocument60
Set secDoc = New MSXML2.DOMDocument60
If secDoc.LoadXML(sectionsXml) Then
' select the Section nodes
Dim secNodes As MSXML2.IXMLDOMNodeList
Debug.Print secDoc.DocumentElement.XML
Dim soapNS
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
secDoc.SetProperty "SelectionNamespaces", soapNS
Set secNodes = secDoc.DocumentElement.SelectNodes("//one:Section")
If Not secNodes Is Nothing Then
' Get the first section.
Dim secNode As MSXML2.IXMLDOMNode
Set secNode = secNodes(0)
Dim sectionName As String
sectionName = secNode.Attributes.getNamedItem("name").Text
Dim sectionID As String
sectionID = secNode.Attributes.getNamedItem("ID").Text
' Create a new blank Page in the first Section
' using the default format.
Dim newPageID As String
OneNote.CreateNewPage sectionID, newPageID, npsDefault
' Get the contents of the page.
Dim outXML As String
OneNote.GetPageContent newPageID, outXML, piAll, xs2013
Dim doc As MSXML2.DOMDocument60
Set doc = New MSXML2.DOMDocument60
' Load Page's XML into a MSXML2.DOMDocument object.
If doc.LoadXML(outXML) Then
' Get Page Node.
Dim pageNode As MSXML2.IXMLDOMNode
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
doc.SetProperty "SelectionNamespaces", soapNS
Set pageNode = doc.SelectSingleNode("//one:Page")
' Find the Title element.
Dim titleNode As MSXML2.IXMLDOMNode
Set titleNode = doc.SelectSingleNode("//one:Page/one:Title/one:OE/one:T")
' Get the CDataSection where OneNote store's the Title's text.
Dim cdataChild As MSXML2.IXMLDOMNode
Set cdataChild = titleNode.SelectSingleNode("text()")
' Change the title in the local XML copy.
cdataChild.Text = "A Page Created from VBA"
' Write the update to OneNote.
OneNote.UpdatePageContent doc.XML
Dim newElement As MSXML2.IXMLDOMElement
Dim newNode As MSXML2.IXMLDOMNode
' Create Outline node.
Set newElement = doc.createElement("one:Outline")
Set newNode = pageNode.appendChild(newElement)
' Create OEChildren.
Set newElement = doc.createElement("one:OEChildren")
Set newNode = newNode.appendChild(newElement)
' Create OE.
Set newElement = doc.createElement("one:OE")
Set newNode = newNode.appendChild(newElement)
' Create TE.
Set newElement = doc.createElement("one:T")
Set newNode = newNode.appendChild(newElement)
' Add the text for the Page's content.
Dim cd As MSXML2.IXMLDOMCDATASection
Set cd = doc.createCDATASection("Is this what I need to change?")
newNode.appendChild cd
' Update OneNote with the new content.
OneNote.UpdatePageContent doc.XML
' Print out information about the update.
Debug.Print "A new page was created in "
Debug.Print "Section " & sectionName & " in"
Debug.Print "Notebook " & noteBookName & "."
Debug.Print "Contents of new Page:"
Debug.Print doc.XML
End If
Else
MsgBox "OneNote 2010 Section nodes not found."
End If
Else
MsgBox "OneNote 2010 Section XML Data failed to load."
End If
Else
MsgBox "OneNote 2010 XML Data failed to load."
End If
End Sub
Private Function GetAttributeValueFromNode(node As MSXML2.IXMLDOMNode, attributeName As String) As String
If node.Attributes.getNamedItem(attributeName) Is Nothing Then
GetAttributeValueFromNode = "Not found."
Else
GetAttributeValueFromNode = node.Attributes.getNamedItem(attributeName).Text
End If
End Function
Private Function GetFirstOneNoteNotebookNodes(OneNote As OneNote.Application) As MSXML2.IXMLDOMNodeList
' Get the XML that represents the OneNote notebooks available.
Dim notebookXml As String
' OneNote fills notebookXml with an XML document providing information
' about what OneNote notebooks are available.
' You want all the data and thus are providing an empty string
' for the bstrStartNodeID parameter.
OneNote.GetHierarchy "", hsNotebooks, notebookXml, xs2013
' Use the MSXML Library to parse the XML.
Dim doc As MSXML2.DOMDocument60
Set doc = New MSXML2.DOMDocument60
If doc.LoadXML(notebookXml) Then
Dim soapNS
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
doc.SetProperty "SelectionNamespaces", soapNS
Set GetFirstOneNoteNotebookNodes = doc.DocumentElement.SelectNodes("//one:Notebook")
Debug.Print doc.DocumentElement.XML
Else
Set GetFirstOneNoteNotebookNodes = Nothing
End If
End Function
Thanks for your help.

Are you using OneDrive for Business? If so, these Microsoft Flow templates might be very useful: https://ms.flow.microsoft.com/en-us/services/shared_onenote/onenote-business/. In particular, one is for sending important e-mails to OneNote. You can also create your own flow that has different triggers, and specify the name of the page/section you want to create.
Here is an example flow:
Note the "Add Dynamic Content" button. This allows you to specify the name and content of the section.
If you're not using O365, you might be able to use the Microsoft Graph API and the OneNote REST API together to achieve what you want. There aren't VBA examples but there are many others.

Related

Loop through all views in Lotus Notes with Excel VBA script

I have a script (found on the web and adjusted to my needs) that can access a specific view of Lotus Notes, pick up some info from each email and save any attachment to a given folder. If I want to do this for more views I currently have the names of these views in my worksheet and loop through them.
What I would like to do is to loop through all views and do the same.
I am not a professional developer and not yet entirely familiar working with objects. This problem however is to complicated for me. The Lotus Notes object is also not the easiest to understand.
I am using the following code which of course is part of a larger (working) script. For starters it would be enough to just be able to loop through all views and print the Name of the view. From there on I think I can do the rest myself.
Can anyone adjust the code to make it work.
Public Sub Get_Notes_Email_Text()
Dim NSession As Object 'NotesSession
Dim NMailDB As Object 'NotesDatabase
Dim NDocs As Object 'NotesDocumentCollection
Dim NDoc As Object 'NotesDocument
Dim NNextDoc As Object 'NotesDocument
Dim view As String
'Start a Lotus Notes session
Set NSession = CreateObject("Notes.NotesSession")
'Connect to the Lotus Notes database
Set NMailDB = NSession.GetDatabase("", "C:\Users\" & Environ("Username") & "\AppData\Local\IBM\Notes\Data\mail\" & Environ("Username") & ".nsf") 'Default server en database
If Not NMailDB.IsOpen Then
NMailDB.OpenMail
End If
'Loop through all views and print .Name tot Immediate Window
' Dim Map As Variant
' Dim Mappen As Object
' Set Mappen = NMailDB.Views
'
' For Each Map In Mappen
' Debug.Print Map.Name
' Next Map
'
End Sub
Easier than going through all views is to just go to one view that shows all documents. If it is a mail database, then the view is called "($All)"
Set allDocsView = NMailDB.getView("($All)")
allDocsView.autoUpdate = false
You can then loop through the documents in the view using
Set docToProcess = allDocsView.GetFirstDocument
While Not ( docToProcess Is Nothing )
'Do what you plan to do here
Set docToProcess = allDocsView.GetNextDocument( docToProcess )
Wend
UPDATE:
As you want to loop through Folders, not views, you need to do something like the following
Dim sess As New notessession
Dim db As NotesDatabase
Dim views As Variant
Set db = sess.CurrentDatabase
views = db.Views
Forall v In views
If v.isFolder Then ' Needed so that we are only processing Folder objects and not views - you will need to check that you are not processing system folders e.g. $Inbox etc
'Do your processing of documents here
End If
End Forall

MSXML2 - How to search specific nodes and replace its child nodes

I have this XML file
I need to search for the <deviceset> element by its name (for example name="DB_") and replace its children subtree <technologies> with updated data.
So far I made function that returns MSXML2.IXMLDOMElement <technologies> with correct structure, but I have no clue how to search and replace in the main document.
I'm trying this approach
'Select everything from table Interlink - This table contains element's names
Dim RS As Recordset
Set RS = CurrentDb.OpenRecordset("SELECT * FROM Interlink")
'Create new document and load the file
Dim oDoc As DOMDocument60
Set oDoc = New DOMDocument60
oDoc.async = False
oDoc.Load CurrentProject.Path & "\JLC_pattern.xml"
Dim Tech As IXMLDOMElement 'I can set this to contain updated <technologies> subtree
'is it better to use IXMLDOMNode? or IXMLDOMDocumentFragment?
Dim devSets As IXMLDOMNodeList 'Collection ?
Dim devSet As IXMLDOMNode 'Node?
'Loop through the recordset, search for elements and replace the subtree <technologies>
Do Until RS.EOF
'Recordset now contains the deviceset name attribute
Debug.Print RS.Fields("lbrDeviceSetName") ' first record contains "DB_"
'I can't find the right method to find the node or collection
'I have tried:
Set devSets = oDoc.getElementsByTagName("deviceset") 'and
Set devSets = oDoc.selectNodes("//eagle/drawing/library/devicesets/deviceset")
'but devSets collection is always empty
For Each devSet In devSets
Debug.Print devSet.baseName ' this does not loop
Next devSet
'I made a function that returns IXMLDOMNode with needed data structure
'Once I find the node I need to replace the subtree
'and move to the next deviceset name
RS.MoveNext
Loop
'Save the modified XML document to disk
oDoc.Save CurrentProject.Path & "\SynthetizedDoc.xml"
RS.Close
'Cleanup...
It may be easier to loop through the collection of nodes and search the recordset instead of looping through the recordset and search the nodes.
Can anyone give me a clue please?
EDIT: I have expanded the VBA code with for each loop
Pattern XML is here JLC_Pattern.xml
EDIT 2: The <technologies> subtree can be quite huge. I don't want to overwhelm this post by code. I have a function getTechnology(tech as string) as IXMLDOMElement that pulls data from DB. Function output content can be downloaded here: IXMLDOMElement.xml The issue is not this function, I just don't know how to insert this output into the correct place of the oDoc
This works for me:
'Create new document and load the file
Dim oDoc As DOMDocument60
Dim devSet As IXMLDOMNode
Set oDoc = New DOMDocument60
oDoc.async = False
'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/ms762632(v=vs.85)
oDoc.SetProperty "ProhibitDTD", False 'needed for MSXML6
oDoc.validateOnParse = False 'or get a DTD-related error
'"The element 'eagle' is used but not declared in the DTD/Schema."
'always test for load errors
If Not oDoc.Load("C:\Tester\JLC_pattern.xml") Then
Debug.Print oDoc.parseError.reason
Exit Sub
End If
'select a single node based on its name attribute value
Set devSet = oDoc.SelectSingleNode("/eagle/drawing/library/devicesets/deviceset[#name='DB_']")
If Not devSet Is Nothing Then
Debug.Print devSet.XML
'work with devSet child nodes...
Else
Debug.Print "node not found"
End If

Automation of PDF String Search using Excel VBA - OLE error

I'm getting this error, "Microsoft Excel is waiting for another application to complete an OLE action" when trying to automate a PDF string search and record findings in excel. For certain PDFs this error is not popping. I assume this is due to the less optimized PDFs taking a longer time to search string while indexing page by page.
To be more precise, I have a workbook containing two sheets. One contains a list of PDF file names and the other has a list of words that I want to search. From the file list the macro would open each PDF file and take each word from the list of words and perform a string search. If found it would record each finding in a new sheet in the same workbook with the file name and the found string.
Below is the code I'm struggling with. Any help is welcome.
Public Sub SearchWords()
'variables
Dim ps As Range
Dim fs As Range
Dim PList As Range
Dim FList As Range
Dim PLRow As Long
Dim FLRow As Long
Dim Tracker As Worksheet
Dim gapp As Object
Dim gAvDoc As Object
Dim gPDFPath As String
Dim sText As String 'String to search for
FLRow = ActiveWorkbook.Sheets("List Files").Range("B1").End(xlDown).Row
PLRow = ActiveWorkbook.Sheets("Prohibited Words").Range("A1").End(xlDown).Row
Set PList = ActiveWorkbook.Sheets("Prohibited Words").Range("A2:A" & PLRow)
Set FList = ActiveWorkbook.Sheets("List Files").Range("B2:B" & FLRow)
Set Tracker = ActiveWorkbook.Sheets("Tracker")
'For each PDF file list in Excel Range
For Each fs In FList
'Initialize Acrobat by creating App object
Set gapp = CreateObject("AcroExch.App")
'Set AVDoc object
Set gAvDoc = CreateObject("AcroExch.AVDoc")
'Set PDF file path to open in PDF
gPDFPath = fs.Cells.Value
' open the PDF
If gAvDoc.Open(gPDFPath, "") = True Then
'Bring the PDF to front
gAvDoc.BringToFront
'For each word list in the range
For Each ps In PList
'Assign String to search
sText = ps.Cells.Value
'This is where the error is appearing
If gAvDoc.FindText(sText, False, True, False) = True Then
'Record findings
Tracker.Range("A1").End(xlDown).Offset(1, 0) = fs.Cells.Offset(0, -1).Value
Tracker.Range("B1").End(xlDown).Offset(1, 0) = ps.Cells.Value
End If
Next
End If
'Message to display once the search is over for a particular PDF
MsgBox (fs.Cells.Offset(0, -1).Value & " assignment complete")
Next
gAvDoc.Close True
gapp.Exit
set gAVDoc = Nothing
set gapp = Nothing
End Sub
I have now found the answer to this problem.
I'm using Acrobat Pro and whenever I open a PDF file, it opens with limited features due to Protected View settings. If I disable this function or if I click Enable All Features and save changes to the PDF files, VBA macro runs smooth.
It's funny, I'm posting an answer to my own problem.

Copying from Internet Explorer text area (box) but into more than a single cell

I'm currently trying to control/automate a postcode looking website from postcodes stored and updated in Excel, and my code works perfectly up to the point it has to copy the data once it's finished. For the life of me I can't figure out how to copy the data from the text box / area into Excel without it just putting it ALL into one cell (Text to Columns doesn't really work either).
The website is : http://www.doogal.co.uk/DrivingDistances.php
Sub Geo2()
Dim sht As Worksheet
Dim IE As Object
'Dim ieDoc As HTMLDocument
Dim Item As Variant
Dim objElement As Object
Dim startLoc As String
Dim endLoc As String
Dim x As Integer
Dim objNotes As Object
Dim strNotes As String
Dim str As String
'Dim SignInButton As HTMLInputButtonElement
Set sht = ThisWorkbook.Sheets("Postcode")
Set IE = CreateObject("InternetExplorer.Application")
'Open IE
IE.Visible = True
IE.Navigate "http://www.doogal.co.uk/DrivingDistances.php"
'Wait until site is loaded
Do While IE.ReadyState <> 4 'READYSTATE_COMPLETE
DoEvents
Loop
IE.Document.getElementbyID("startLocs").Value = "dn1 5pq" 'random postcode
IE.Document.getElementbyID("endLocs").Value = "wf12 2fd" 'random postcode
IE.Document.getElementsByName("calculateFor").Item(1).Checked = True
IE.Document.getElementsByName("units").Item(1).Checked = True
IE.Document.getElementsByClassName("btn btn-primary").Item(0).Click
------
'Ive tried without having it as a object and using .value but it either comes with only the first line or the entire thing rammed into a string and is unusable
----Code here is the problem-----
***Set objNotes = IE.Document.getElementbyID("distances")
str = objNotes.Value***
---------
Do While IE.ReadyState <> 4 'READYSTATE_COMPLETE
DoEvents
Loop
End Sub
The following VBA function uses the Google Maps Directions API to calculate the driving distance in meters between two locations. The code is modified from a version submitted by barrowc on this similar question.
Make sure to add a reference in Excel to Microsoft XML, v6.0.
Function getDistance(origin As String, destination As String) As String
Dim xhrRequest As XMLHTTP60
Dim domDoc As DOMDocument60
Dim ixnlDistanceNode As IXMLDOMNode
Dim RequestString As String
Dim API_Key As String
' Insert your own Google Maps Directions API key here
API_Key = "XXXXXX"
' Read the data from the website
Set xhrRequest = New XMLHTTP60
RequestString = "https://maps.googleapis.com/maps/api/directions/xml?origin=" _
& origin & "&destination=" & destination & "&sensor=false&key=" & API_Key
xhrRequest.Open "GET", RequestString, False
xhrRequest.send
' Copy the results into a format we can manipulate with XPath
Set domDoc = New DOMDocument60
domDoc.LoadXML xhrRequest.responseText
' Select the node called value underneath the leg and distance parents.
' The distance returned is the driving distance in meters.
Set ixnlDistanceNode = domDoc.SelectSingleNode("//leg/distance/value")
getDistance = ixnlDistanceNode.Text
Set ixnlDistanceNode = Nothing
Set domDoc = Nothing
Set xhrRequest = Nothing
End Function
Please note that this code by itself violates the Terms of Use of Google's API. "The Google Maps Directions API may only be used in conjunction with displaying results on a Google map; using Directions data without displaying a map for which directions data was requested is prohibited."1
Instead of putting the data all in one string, Split the string into an array, then loop through the array like this:
Set objNotes = IE.Document.getElementbyID("distances")
Dim x as Integer
Dim aDist() as Variant
aDist = Split(objNotes.Value, vbNewLine) 'May need to be vbCr or vbLf or vbCrLf
For x = 0 to Ubound(aDist) - 1
debug.print aDist(x)
Next x

Using VBA to get extended file attributes

Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"