I connected the SharePoint to network drive.We have added few attributes like "status" and "Rejection reason" to SharePoint files. We want to extract those properties using VBA.
![Custom added properties
We have tried accessing those properties using extended properties of document but it is not available there.
{
Sub LoopThroughFiles()
Dim oFSO, Oshell, ODir, wordapp, Doc As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
'Dim Doc As Document
Set Oshell = CreateObject("Shell.Application")
Set wordapp = CreateObject("word.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("S:\Shared Documents\General\")
Set ODir = Oshell.Namespace("S:\Shared Documents\General\")
For Each oFile In ODir.Items
'MsgBox oFile.Status
'Workbook.Open file:=oFile
'Set Doc = wordapp.Documents.Open(oFile.Path)
'MsgBox Doc.BuiltinDocumentProperties("status")
For i = 0 To 1000
'MsgBox ODir.GetDetailsOf(sFile, 0).Value
Cells(i + 1, 1) = ODir.GetDetailsOf(oFile, i)
Cells(i + 1, 2) = ODir.GetDetailsOf(, i)
Next
Next oFile
End Sub
}
Can you please help us in extracting those.
Thanks in advance
try to use "CustomDocumentProperties" istead of "BuiltinDocumentProperties"
Related
I need help to make this vba code to work in mac (it's running perfect under windows but I have users that have only mac), the code extracts body data from selected emails in outlook and sends the info to a sheet.
I tried reading all the posts here about late binding and I got how it works, basically not referencing libraries that doesn't exist in mac office versions. I've changed the line that is causing trouble in my code "Dim objMail As Outlook.MailItem" for "Dim objMail As Object" it runs, but the macro goes directly to the msg box line without performing anything (I think ohh is running the code but I've tried debugging it but is not getting any variable or any information when I run it and I didn't get any error msg)
Sub DetailExtraction()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application") ' late binding
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder As Object
Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEMS IN THE FOLDER.
'For Each objItem In myFolder.Items
' LOOP THROUGH EACH ITEMS IN THE SELECTION.
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Dim objMail As Outlook.MailItem
Set objMail = objItem
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 6) = objMail.Body
Cells(iRows, 6).WrapText = False
'MsgBox Prompt:=objMail.Body
End If
'WRAP UP FILE OFF
' Cells*i.WrapText = False
' SHOW OTHER PROPERTIES, IF YOU WISH.
'Cells(iRows, 6) = objMail.Body
'Cells(iRows, 5) = objMail.CC
'Cells(iRows, 6) = objMail.BCC
'Cells(iRows, 4) = objMail.Recipients(1)
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
Application.ScreenUpdating = True
MsgBox "Environments Details Extracted from the Selected Emails (" & iRows - 2 & ")"
End Sub
Thanks in advance!
I'm trying to export sender email address and recipient email addresses (to and cc) to Excel. I adapted code I found online. It does most of what I need but there are two problems:
It only works with a single recipient. If there are two or more recipients, it provides names (e.g. Jo Bloggs) instead of email addresses.
It only includes people in the 'To' field, not those in the 'CC' field.
I think the bit that needs fixing is:
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
Full code:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim olItem 'As Outlook.MailItem
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
xlSheet.Range("A1") = "Sender Name"
xlSheet.Range("B1") = "Sender Email"
xlSheet.Range("C1") = "Subject"
xlSheet.Range("D1") = "Body"
xlSheet.Range("E1") = "Sent To"
xlSheet.Range("F1") = "Date"
End If
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each obj In objItems
Set olItem = obj
'collect the fields
strColA = olItem.SenderName
strColB = olItem.SenderEmailAddress
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)
If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
xlWB.Save
Next
' don't wrap lines
xlSheet.Rows.WrapText = False
xlWB.Save
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Iterating through all items in the folder is not really a good idea. I'd recommend starting from the Find/FindNext or Restrict methods instead. Please note that there are some item properties that you can’t use for the filter. You can read more about the properties not allowed in the filter string and string formats used for the search criterion on MSDN.
The following example uses the Restrict method to get all Inbox items of Business category and moves them to the Business folder. To run this example, create or make sure a subfolder called 'Business' exists under Inbox:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Categories] = 'Business'")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Please remember that you can set a suitable filter (View | View Settings |filter) on a folder and study the filter string on the SQL tab of the Filter dialog. Then you can construct any required filter string in the code.
If woudl be nice to use Items.Find/FindNext or Items.Restrict, but I cannot think of a query that would let you do what you want. If it is a one time thing, you have no choice but to loop through all items in a folder and for each item loop through all recipients and compare each recipient's entry id (Recipient.EntryID) with the sender entry id (MailItem.Sender.EntryId).
I'd like to get some attributes from emails stored in a local folder. I know how to do it for emails in Outlook.folder but I guess the methods are not the same in that case.
I can't find a way to work with the .msg items as if they were emails.
I haven't try anything since I understand the problem comes from object class incompatibility, but I don't know what to use. Also, I couldn't find a guide on ".msg" item, could be useful
Private Sub email_listing()
On Error GoTo ErrHandler
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder, fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set myFolder = fs.GetFolder("C:\Users\boris\Desktop\Mail Test\")
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEM IN THE FOLDER.
For Each Item In myFolder.Files
If Item.Type = "Outlook Item" Then
Dim objMail As Outlook.MailItem
Set objMail = Item 'THE BUG
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 5) = objMail.Body
End If
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
I expect to have the attributes for each mail in my spreadsheet.
So far the code stop at line 27
Use Namespace.OpenSharedItem to open standalone MSG files.
I am working on a macro to open a file(might already be open) and save with new name and then open the new file from vba in excel.
This file can Powerpoint,mathcad,visio, word etc..(can also be template files such as dotx etc..)
So my idea is that:
I first need to figure out if the application is open or not,
then I somehow need to figure if the file is open or not,
then save it with the new filename.
Open the new document
Go through the document and dumps custom variables into the database, populate custom variables from database(Not shown in code below, seperate module)
Activate the new document so that the user can edit it.
Public Sub saveAsVBADocument(filenameNew As String, fileNameOld As String, applicationType As String)
Dim objectApplication As Object
Dim documentApplication As Object
On Error Resume Next
Set objectApplication = GetObject(, applicationType)
On Error GoTo 0
If objectApplication Is Nothing Then
Set objectApplication = CreateObject(applicationType)
End If
objectApplication.Visible = True
On Error Resume Next
Set documentApplication = objectApplication.Workbooks(FileHandling.GetFilenameFromPath(fileNameOld)) 'Excel
Set documentApplication = objectApplication.Documents(FileHandling.GetFilenameFromPath(fileNameOld)) 'Word
Set documentApplication = objectApplication.WorkSheets(FileHandling.GetFilenameFromPath(fileNameOld)) 'Mathcad
Set documentApplication = objectApplication.Presentations(FileHandling.GetFilenameFromPath(fileNameOld)) 'PowerPoint
Set documentApplication = objectApplication.Projects(FileHandling.GetFilenameFromPath(fileNameOld)) 'MS Project "Msproject.Application"
Set documentApplication = objectApplication.Documents(FileHandling.GetFilenameFromPath(fileNameOld)) 'MS Visio "Visio.Application"
If documentApplication Is Nothing Then
Set documentApplication = objectApplication.FileOpen(fileNameOld) ' add read only
End If
documentApplication.SaveAs filename:=filenameNew
Set objectApplication = Nothing
Set documentApplication = Nothing
End Sub
What is a possible solution to handle all vba acceptable document types?
You can use GetObject("Filename") to open a file directly in its application. So something like this can open any file that has its extension in the Windows Registry. That will be most file types; certainly the Office applications. Whether you'll be able to use SaveAs will depend on whether those applications support OLE Server (meaning they have a coding interface exposed). Again, all the Office applications do support this.
You'll probably want to put in some error-handling for the case the application for the file extension can't be found in the Registry. And of course in case the file name doesn't exist.
My example is for Excel and Word, only - you should be able to fill in others. My code makes sure the file is visible and available to the user as that makes it easier to trouble-shoot. You can, of course, change that once you have everything working satisfactorily.
Sub OpenFileInUnknownApp()
Dim objFile As Object
Dim objApp As Object
Dim sPath As String, sExt As String
Dim sFileName As String
Dim sAppName As String
Dim snewfilename As String
sPath = "C:\Test\"
sFileName = sPath & "Quote.docx" 'RngNames.xlsx"
snewfilename = sPath & "NewName"
'''Open the file in its application
Set objFile = GetObject(sFileName)
Set objApp = objFile.Application
sAppName = objApp.Name
Select Case sAppName
Case Is = "Microsoft Excel"
Dim wb As Excel.Workbook
sExt = "xlsx"
objApp.Visible = True
Set wb = objFile
wb.Activate
wb.Windows(1).Visible = True
objApp.UserControl = True 'so that it "lives" after the code ends
objApp.Activate
wb.SaveAs "sNewFileName" & sExt
Case Is = "Microsoft Word"
Dim doc As word.Document
sExt = "docx"
objApp.Visible = True
Set doc = objFile
objApp.Activate
doc.SaveAs2 "sNewFileName" & sExt
Case Else
End Select
Set objFile = Nothing
Set objApp = Nothing
End Sub
I'm trying to write a VBA script to gather metrics on a shared mailbox throughout the day. Essentially, I'm wanting to export to Excel how many new, sent, and received messages where detected at different times throughout the day.
I'm working with the code below, however am getting an error when I try running the script. The error states:
"Run-time error '13'" Type mismatch"
Debugging highlights the error at Next olMail.
Does anyone have any ideas on what is causing this error, or if I need to be going at this from another direction? Also, I don't believe I have this setup correctly for my shared mailbox, as my default email is not shared. How do I need to modify Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) for the script to recognize I need it to read the shared box?
I'm using Outlook 2013.
Sub EmailStats()
Dim olMail As MailItem
Dim aOutput() As Variant
Dim lCnt As Long
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
Dim flInbox As Folder
Set flInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
ReDim aOutput(1 To flInbox.Items.Count, 1 To 4)
For Each olMail In flInbox.Items
If TypeName(olMail) = "MailItem" Then
lCnt = lCnt + 1
aOutput(lCnt, 1) = olMail.SenderEmailAddress
aOutput(lCnt, 2) = olMail.ReceivedTime
aOutput(lCnt, 3) = olMail.ConversationTopic
aOutput(lCnt, 4) = olMail.Subject
End If
Next olMail
Set xlApp = New Excel.Application
Set xlSh = xlApp.Workbooks.Add.Sheets(1)
xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Visible = True
End Sub
I figure if I can get the above to work, I can piece together the rest in Excel, though if anyone knows a better way any advice is definitely appreciated.
Lastly, where would I start if I'd like to add the ability to the script to export this information for individual sub-folders and/or categories? Is this possible?
Any point in the right direction I would be very grateful for.
Using the answer given by #Dmitry Streblechenko on this link:Get reference to additional Inbox
I've included the ResolveDisplayNameToSMTP function by Sue Mosher to wrap around the SenderEmailAddress.
Sub EmailStats()
Dim olMail As MailItem
Dim aOutput() As Variant
Dim ns As Outlook.NameSpace
Dim vRecipient As Recipient
Dim lCnt As Long
' Dim xlApp As Excel.Application
' Dim xlSh As Excel.Worksheet
Dim flInbox As Folder
Set ns = Application.GetNamespace("MAPI")
Set vRecipient = ns.CreateRecipient("<top level folder of shared inbox>")
If vRecipient.Resolve Then
Set flInbox = ns.GetSharedDefaultFolder(vRecipient, olFolderInbox)
End If
ReDim aOutput(1 To flInbox.Items.Count, 1 To 4)
For Each olMail In flInbox.Items
If TypeName(olMail) = "MailItem" Then
lCnt = lCnt + 1
aOutput(lCnt, 1) = ResolveDisplayNameToSMTP(olMail.SenderEmailAddress, Outlook.Application)
aOutput(lCnt, 2) = olMail.ReceivedTime
aOutput(lCnt, 3) = olMail.ConversationTopic
aOutput(lCnt, 4) = olMail.Subject
End If
Next olMail
' Set xlApp = New Excel.Application
' Set xlSh = xlApp.Workbooks.Add.Sheets(1)
' xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
' xlApp.Visible = True
End Sub
'----------------------------------------------------------------------------------
' Procedure : ResolveDisplayNameToSMTP
' Author : Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding.
'-----------------------------------------------------------------------------------
Public Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String
Select Case Val(OLApp.Version)
Case 11 'Outlook 2003
Dim oSess As Object
Dim oCon As Object
Dim sKey As String
Dim sRet As String
Set oCon = OLApp.CreateItem(2) 'olContactItem
Set oSess = OLApp.GetNamespace("MAPI")
oSess.Logon "", "", False, False
oCon.Email1Address = sFromName
sKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
oCon.FullName = sKey
oCon.Save
sRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), sKey, ""))
oCon.Delete
Set oCon = Nothing
Set oCon = oSess.GetDefaultFolder(3).Items.Find("[Subject]=" & sKey) '3 = 'olFolderDeletedItems
If Not oCon Is Nothing Then oCon.Delete
ResolveDisplayNameToSMTP = sRet
Case 14 'Outlook 2010
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
Case Else
'Name not resolved so return sFromName.
ResolveDisplayNameToSMTP = sFromName
End Select
End Function