office 365 mail unable to open notes Link which - lotus-domino

Case happen:
User From Notes Mail change to Office 365, their email contain Lotus notes link(Document link) which cannot be accessible.
Call rtBody.Appenddoclink(LateInVw, "", "Click to view your attendance today") ,
I put the "NotesView"into the email body which not show up on office 365. May i know office 365 have any way to identify this is notes Client application and try to open the notes application of that view?
Dim tdy As Variant
Sub Initialize()
Print"Agent:Request for LateIn Reason started running at " & DateValue(Now()) & "," + TimeValue(Now())
On Error GoTo errhandler
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim LateInVw As NotesView
Dim LateInDocs As NotesViewEntryCollection
Dim LateEntry As NotesViewEntry
Dim LateDoc As NotesDocument
Dim StaffVw As NotesView, StaffDoc As NotesDocument
Dim AttVw As NotesView, Attdoc As notesdocument
Dim MailDoc As NotesDocument
Dim rtBody As NotesRichTextItem
Set db=ss.Currentdatabase
Set LateInVw=db.getview("($Today Not Alerted Late-In Time Records)")
Set StaffVw=db.getview("($Active Staff by ID)")
Set AttVw = db.Getview("($Effective Attendance Setting By ID)")
tdy=Datevalue(Now)
'get all time records for today
Set LateInDocs=LateInVw.Allentries
Set lateEntry=LateInDocs.getfirstentry
Do While Not LateEntry Is Nothing
Set LateDoc=LateEntry.Document
Set Attdoc=Attvw.Getdocumentbykey(LateDoc.TStaffID(0), True)
If Attdoc.LateAtt(0)="Yes" Then
If Not ApprovedLateIn(LateDoc, LateDoc.TAmend(0), False) Then
'get staff mail
Set staffDoc=StaffVw.Getdocumentbykey(LateDoc.TStaffID(0), True)
If Not staffdoc Is Nothing Then
'send email with link to main menu
email$=staffDoc.email(0)
Set Maildoc=New NotesDocument(db)
maildoc.Sendto=email$
maildoc.Subject="Smartcard Attendance System: Late-In Notification for " +Format$(LateDoc.TDate(0),"dd/mm/yyyy")
Set rtBody=New NotesRichTextItem(maildoc, "Body")
Call rtBody.appendtext(" Dear"+" "+ staffDoc.StaffName(0)+",")
Call rtBody.AddNewline(2)
Call rtBody.appendtext("You clocked in to work today at "+lateDoc.TAmend(0)+". Please click on the link below to submit your reason for the late attendance. Thank You!")
Call rtBody.Addnewline(1)
Call rtBody.Appenddoclink(LateInVw, "", "Click to view your attendance today")
Call rtBody.Addnewline(2)
Call rtBody.Appendtext("***If the box to key in the late-in reason does not appear, kindly use the 'History Attendance' to key-in instead.")
maildoc.send(False)
End If
End If
'End If 'check late-in on/off in attendance settings
LateDoc.LateInAlert="Send"
Call LateDoc.save(True,False)
End If 'check late-in on/off in attendance settings
Set LateEntry=LateInDocs.Getnextentry(LateEntry)
Loop
Print"Agent:Request for LateIn Reason ended running at " & DateValue(Now()) & "," + TimeValue(Now())
Exit Sub
errhandler:
Print "Got error " & Error$ & " on line " & CStr(Erl)
Resume next
Print"Agent:Request for LateIn Reason ended running at " & DateValue(Now()) & "," + TimeValue(Now())
End Sub
This is my sample rewrite code as Mime format...
Sub Initialize
Dim ss As New NotesSession
Dim db As NotesDatabase
Dim vw As NotesView
'Dim Doc As NotesViewEntryCollection
Dim LateInVw As NotesView
Dim Ec As NotesViewEntryCollection
Dim Entry As NotesViewEntry
Dim Doc As NotesDocument
Dim MailDoc As NotesDocument
Dim rtBody As NotesRichTextItem
Set db=ss.Currentdatabase
Set vw=db.getview("(test send mail)")
tdy=DateValue(Now)
%Rem
Set replydoc = db.Createdocument()
Call replydoc.Replaceitemvalue("Form", "Memo")
Call replydoc.Replaceitemvalue("Subject", "Pre-check Passed - " + apptitle)
Call replydoc.Replaceitemvalue("SendTo", indoc.From(0))
Call replydoc.Replaceitemvalue("BlindCopyTo", mailinadd)
Set body = replydoc.Createmimeentity
%End Rem
Set EC = vw.Allentries
Set Entry=Ec.getfirstentry
Do While Not Entry Is Nothing
Set Doc = Entry.Document
email$="chee111385#gmail.com"
Set Maildoc= db.Createdocument()
Call Maildoc.Replaceitemvalue("Form", "Memo")
Call Maildoc.Replaceitemvalue("Subject", "Test Send Mail, Mime Format")
Call Maildoc.Replaceitemvalue("SendTo",email$)
Set body = Maildoc.Createmimeentity
ss.Convertmime = False
Set stream = ss.Createstream()
stream.Writetext(|<html><body>|)
stream.Writetext(|<p>Dear Sir, | + |,</p>|)
stream.Writetext(|<p>This is a testing mail. Thanks You!<br>| + |</p>|)
stream.Writetext(|<p>|+|Notes://Mulu/482577AE00260EC5/|+ +Doc.Universalid+|</p>|)
Call stream.Writetext(|</body></html>|)
Call body.Setcontentfromtext(stream, "text/html;charset=UTF-8", 1725)
Call maildoc.Send(False)
ss.Convertmime = True
Set Entry = EC.Getnextentry(Entry)
Loop
End Sub
I not sure how to just open notes document directly...as everytime i click the link it go to the frameset itself...which is not correct!

If you're asking about just this one application, then what you need to do is learn about notes:// URLs, which you can read about here. You just need to change your code to generate a correctly formatted URL for the view, either instead of or in addition to the doclink. When the user clicks the notes:// URL, the Notes client will open and take the user to the view.
If, however, you actually have lots of applications that send doclinks to users, than you may want to look for a solution that installs on your Domino server and handles this automatically for all the applications without you having to change any code. A company called Genii Software has a product called CoExLinks Fidelity that does this.

Related

Multiple MS Access Databases + Outlook (VBA) hanging during scheduled task run

I have created several MS Access databases that connect to my company's SQL server (MSSQL), perform calculations, then export the results in the form of email. These are set up to run through the windows task scheduler at a certain time of the day. Before you ask, I do not have access to the SQL server so I cannot create any stored procedures or do anything other than read. These run on a desktop computer under my desk which is on 100% of the time (other than a weekly reboot).
The issue I am having is with using VBA in MS Access to actually send the emails. All of the SQL and excel formatting work as intended, but I ran into the issue of Access closing Outlook before the email leaves my outbox. Attempts to make Access wait or sleep until emails have been sent are causing the program to indefinetly hang. I would greatly appreciate any help you can provide on how to resolve this issue.
Thank you and please see below. My best guess at this point is that the sleep or wait methods I have used get stuck when two seperate Access Databases attempt to use them at the same time. I suspect this because when I run each process independently to debug, they are able to run without issues.
Windows Task Scheduler:
6:30AM (Task 1)(Run Time 2mins)- Access opens an internet page, pulls data, formats in excel, and saves to a network drive where a different program (not written by me) scoops up the data at 7:00 and uploads to SQL server. This is the first scheduled task and rarely has issues.
7:30AM (Task 2)(Run Time 5 mins) - Access connects to SQL, runs queries, exports results to excel file (no email).
7:35AM (Task 3)(Run Time 1.5hours) - Access connects to SQL, runs lots of very big queries, then exports file to excel and attempts to send emails. This one has issues where file is created and when I attempt to email, it either sits in outbox until I open outlook or file is created and it has trouble sending the email.
8:00AM (Task 4)(Run Time 3 mins) - Access connects to SQL, runs queries, sends emails. Usually has no issues but occasionally emails get stuck in Outbox.
8:00AM (Task 5)(Run Time 30 mins) - Access connects to SQL, runs queries, gets files from task 2, sends emails.
For all tasks, these are the settings:
Run only when user is signed on.
Run with highest privileges.
Action - Start a program (.bat)
The .bat files have this general format:
#echo on
cscript SCRIPT_NAME.vbs
The .vbs files have this general format:
Dim oAccessApp
Set oAccessApp = createObject("Access.Application")
oAccessApp.OpenCurrentDataBase("C:\PATHNAME.accdb")
oAccessApp.Visible = True
oAccessApp.Run "VBA_FUNCTION_NAME", "PARAMETERS"
oAccessApp.Application.Quit
Set oAccessApp = nothing
Outlook VBA Module
I suspect the issue I am having is related to the way I am sending the emails because the files output correctly even if the emails are not sent. Also, the code is able to run correctly when I test each .bat independently. Below please find my code that I use to send the emails.
Option Compare Database
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Function sendToOutlook(sWhNo As String)
Dim s As String
Dim n As Integer
n = FreeFile()
Open "C:\PATHNAME\logfile.txt" For Output As #n
s = "Hello, world!"
Print #n, s
Dim XL As Excel.Application
Dim XlBook As Excel.Workbook
Dim fileNameLocation As String
Dim olApp As Outlook.Application
Dim olInsp As Outlook.Inspector
Dim olMail As Outlook.MailItem
Dim olAttachments As Outlook.Attachments
Dim subjectStr As String
Dim sWhString As String
Select Case sWhNo
Case "CASE_STATEMENTS_HERE"
subjectStr = "CITY_NAME"
sWhString = subjectStr
'more cases
End Select
Print #n, subjectStr
Print #n, sWhString
toStr = "email1#example.com;email2#example.com, etc"
bccStr = ""
subjectStr = subjectStr & "_" & exportTime & " REPORT_NAME"
fileLocation = "C:\TASK2_FILEPATH"
XlFileFormatStr = ".xlsx"
Print #n, toStr
Print #n, ccStr
Print #n, subjectStr
Print #n, fileLocation
Print #n, XlFileFormatStr
Dim qryRange1 As Excel.Range
Dim sFileLocation As String
Dim sFileName As String
Dim sFullFileNameLoc As String
Dim sMonthNum As String
Dim sDayNum As String
sFileLocation = "C:\CURRENT_TASK_PATHNAME\"
sDayNum = Day(Date)
If sDayNum - 10 < 0 Then sDayNum = "0" & Day(Date)
sMonthNum = Month(Date)
If sMonthNum - 10 < 0 Then sMonthNum = "0" & Month(Date)
sFileName = sWhNo & "_REPORT_NAME_" & Year(Date) & sMonthNum & sDayNum & ".xlsx"
Print #n, sFileName
sFullFileNameLoc = sFileLocation & sFileName
Print #n, sFullFineNAmeLoc
Set XL = CreateObject("Excel.Application")
Set XlBook = XL.Workbooks.Open(sFullFileNameLoc)
XL.DisplayAlerts = False
XL.AskToUpdateLinks = False
XL.EnableEvents = False
XL.Visible = True
Set qryRange1 = XlBook.Sheets("SHEET_NAME").Range(XlBook.Sheets("SHEET_NAME").Cells(1, 1).Address(), XlBook.Sheets("SHEET_NAME").Cells(11, 14).Address())
On Error Resume Next
Set olApp = New Outlook.Application
If Err.Number = 429 Then
Print #n, "429!!!"
Debug.Print "429!!!"
Set olApp = GetObject(, "Outlook.Application")
Set olInsp = olApp.ActiveInspector
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachments = olMail.Attachments
GoTo LBL_CLOSE
End If
Set olInsp = olApp.ActiveInspector
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachments = olMail.Attachments
olMail.SentOnBehalfOfName = "group_mailbox#example.com"
Print #n, "NO 429"
olAttachments.Add ("C:\TASK2_FILEPATH\" & exportFileNameGlobal_FINAL)
LBL_CLOSE:
Set qryRange1 = XlBook.Sheets("SHEET_NAME").Range(XlBook.Sheets("SHEET_NAME").Cells(1, 1).Address(), XlBook.Sheets("SHEET_NAME").Cells(11, 14).Address())
With olMail
.To = toStr
.CC = ccStr
.BCC = bccStr
.Subject = subjectStr
.HTMLBody = "Please find attached blah blah blah " & sWhString & vbCrLf & RangetoHTML(qryRange1, XL)
.Display
End With
Dim olAppNS As Outlook.Namespace
Dim olFolder As Outlook.Folder
With olMail
.Send
End With
XlBook.Close
XL.Quit
Set XlBook = Nothing
Set XL = Nothing
olApp.Quit
Set olApp = Nothing
Set olInsp = Nothing
Set olMail = Nothing
Set olAttachments = Nothing
Dim olApp1 As Outlook.Application
Set olApp1 = New Outlook.Application
Dim mySyncObject As Outlook.SyncObject
Dim sync As Outlook.SyncObject
Set olAppNS = olApp1.GetNamespace("MAPI")
Set olFolder1 = olAppNS.GetDefaultFolder(olFolderOutbox)
Set mySyncObjects = olAppNS.SyncObjects
For i = 1 To mySyncObjects.Count
Set sync = mySyncObjects(i)
sync.Start
Next
Do While olFolder1.Items.Count > 0
Sleep 10000
Loop
Close #n
Sleep 60000
olApp1.Quit
Set olApp1 = Nothing
Please advise what I am doing wrong that is causing access to hang and how I should fix. I greatly appreciate any help that you can provide. Thank you.
If you are using Exchange, you can turn cached mode off - message will be sent immediately. Otherwise you have no choice but to start the sync (SyncObject.Start) and wait for the SyncObject.SyncEnd event to fire.
Because of the nature of Office Applications, I'd guess that you're sleeping its only thread and it literally cannot attempt to send the mail while you're either eating up or throwing away all its CPU time. Instead of polling the mailbox and trying to manually wait for the mailitems to send, try using that SyncObject you've already made to register an event handler.
Here's an idea of what I mean. The following is a new class module:
Dim WithEvents mySync As Outlook.SyncObject
Dim myApp As Outlook.Application
Sub Close_After(ByRef toClose As Outlook.Application, ByRef newSync As Outlook.SyncObject)
Set myApp = toClose
Set mySync = newSync
mySync.Start
End Sub
Private Sub mySync_SyncEnd()
myApp.Quit
End Sub
This wraps around a SyncObject and gives it an event handler that will close the current application.
And in your calling code, do something like:
Dim syncClose As New SyncHandler ' Scope to module so we don't lose the reference
Function sendToOutlook(sWhNo As String)
' ...
Dim olApp1 As Outlook.Application
Set olApp1 = New Outlook.Application
' ...
Set olAppNS = olApp1.GetNamespace("MAPI")
Set olFolder1 = olAppNS.GetDefaultFolder(olFolderOutbox)
Set mySyncObjects = olAppNS.SyncObjects
syncClose.Close_After olApp1, (mySyncObjects(1))
End Function
This passes the first SyncObject into your class, which starts the sync and, when the sync completes, closes the passed-in Outlook.Application. If (for some reason) you have more than one SyncObject you want to wait for you'll have to restructure to ensure all have already finished before closing the app. The concept will be the same, though - build wrappers that register event handlers (or one big wrapper class that handles the events of many individual SyncObjects), but add a check that all the syncs must complete before the Application closes.
Although you indicate you want to use outlook, I found it was easier to not rely on Outlook for sending email, so I've used CDO for a very similar application. See email using Access and VBA without MAPI

VBA, MS Outlook, Folder Item

I want to implement an VBA application, which uses the selected object (E-mail, task, folder).
My try with Application.ActiveExplorer.Selection.Item(i_item) seems to return only mails, tasks, calender entries or notes but never an folder (e.g. 'Inbox\').
When the user selects an e-mail, and then starts the VBA macro, the solution Application.ActiveExplorer.Selection.Item(i_item) delivers the desired results.
However, if the last item picked by the Outlook user was an folder (e.g. 'Sent Mails'). And the VBA makro started afterward, than the macro should recive the Folder Item (without additional user interaction). This is currently not the case. The code above still delivers the e-mail, or task.
How do I check, if the last selection was on an folder (not an e-mail, etc)?
How do I access the Folder item?
If this is not possible I will switch back to Pickfolder (like proposd by Darren Bartrup-Cook) but this is not me prefred solution.
I want to get the selected folder in order to change its icon, so our code is somehow the same.
I noticed that Application.ActiveExplorer.Selection.Item(i_item) it is not perfect, since it throws an exception for empty folders or on calendar etc.
So I use Application.ActiveExplorer.CurrentFolder.DefaultMessageClass (Application.ActiveExplorer.NavigationPane.CurrentModule.Name or Application.ActiveExplorer.NavigationPane.CurrentModule.NavigationModuleType) in order to figure out where I actually am.
By that approach it is easy to get current selected folder
Dim folder As Outlook.MAPIFolder
Dim folderPath As String, currItemType As String
Dim i As Integer
currItemType = Application.ActiveExplorer.CurrentFolder.DefaultMessageClass
If currItemType = "IPM.Note" Then 'mail Item types https://msdn.microsoft.com/en-us/library/office/ff861573.aspx
Set folder = Application.ActiveExplorer.CurrentFolder
folderPath = folder.Name
Do Until folder.Parent = "Mapi"
Set folder = folder.Parent
folderPath = folder.Name & "\" & folderPath
Loop
Debug.Print folderPath
End If
haven't got an problem with it yet. In your case, you can store the selection in a global variable, so you always know which folder was selected last.
This procedure will ask you to select the folder.
If you interrupt the code and examine the mFolderSelected or MySelectedFolder then you should be able to work something out:
Public Sub Test()
Dim MySelectedFolder As Variant
Set MySelectedFolder = PickFolder
End Sub
Public Function PickFolder() As Object
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
On Error GoTo ERROR_HANDLER
Set oOutlook = CreateObject("Outlook.Application")
Set nNameSpace = oOutlook.GetNameSpace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The commented out code will return only email folders. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Not mFolderSelected Is Nothing Then
' If mFolderSelected.DefaultItemType = 0 Then
Set PickFolder = mFolderSelected
' Else
' Set PickFolder = Nothing
' End If
Else
Set PickFolder = Nothing
End If
Set nNameSpace = Nothing
Set oOutlook = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure PickFolder."
Err.Clear
End Select
End Function
NB: This was written to be used in Excel and has late binding - you'll need to update it to work in Outlook (no need to reference Outlook for a start).

Getting "Object variable or With block variable not set" on first use of document.TypeText with Outlook Message

Can anyone help me figure out what's going wrong and how to fix it?
I'm trying to automate sending an email with some daily status information. I'd tried automating this from Access but kept running into (known but apparently unsolved) problems with GetObject(, "Outlook.Application") with Windows 8.1 64 and Outlook 2013. So I decided to automate starting from Outlook.
Anyway, I moved the mail message creation code into Outlook vba and had it start Access and run the Access code. This is all well and good until I get to creating the mail message. Everything starts just fine until it gets to writing to the body of message (using Word as the body editor). At the first "TypeText" command, I'm getting the error message in the title. If I click debug on the error notification dialog and then single-step through the line of code in question, it works just fine. I thought that there was some timing problem, so I stuck a 2-second wait in the code. No luck. The code in question, with some other oddities associated with testing (notably trying to type and then delete text), is below:
Public Sub CreateMetrics()
' Mail-sending variables
Dim mailApp As Outlook.Application
Dim accessApp As Access.Application
Dim mail As MailItem
Dim wEditor As Word.Document
Dim boolCreatedApp As Boolean
Dim i As Integer
Set mailApp = Application
' Create an Access application object and open the database
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase dbLoc
accessApp.Visible = True
' Open the desired form and run the click event hander for the start button
accessApp.DoCmd.OpenForm ("ProcessStatus")
accessApp.Forms![ProcessStatus].StartButton_Click
' Create the outgoing mail message
Set mail = Application.CreateItem(olMailItem)
mail.Display
mail.BodyFormat = olFormatHTML
Set wEditor = mailApp.ActiveInspector.WordEditor
With accessApp.Forms![ProcessStatus]
Debug.Print .lblToList.Caption
Debug.Print .lblSubject.Caption
Debug.Print .lblIntroduction.Caption
Debug.Print .lblAttachFilepath.Caption
End With
mail.To = accessApp.Forms![ProcessStatus].lblToList.Caption
mail.Recipients.ResolveAll
mail.Subject = accessApp.Forms![ProcessStatus].lblSubject.Caption
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
Sleep 2000
' Error occurs in the next line ***********************************************
wEditor.Application.Selection.TypeText Text:="Test"
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.Delete Count:=4
wEditor.Application.Selection.PasteSpecial DataType:=wdPasteBitmap
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.TypeText accessApp.Forms![ProcessStatus].lblIntroduction.Caption
wEditor.Application.Selection.TypeText Text:=Chr(13) & Chr(13)
wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.TypeText Text:=Chr(13)
' wEditor.Application.Selection.TypeText Text:=configs("EmailSignature")
' End With
With mailApp.Session.Accounts
i = 1
Do While i <= .Count
' Use either the specified email address OR the last outlook email address
If RegEx_IsStringMatching(.Item(i).SmtpAddress, accessApp.Forms![ProcessStatus].lblSenderRegex.Caption) Or i = .Count Then
mail.SendUsingAccount = .Item(i)
i = .Count + 1
Else
i = i + 1
End If
Loop
End With
mail.Save
accessApp.Quit
End Sub
I added a "mail.Display" just before the line that was causing the failure, which seemed, incorrectly, to have fixed the problem.
I have now solved this problem by executing a document.select on the document associated with the email I was creating. To select the right document (there doesn't seem to be any guarantee of which one that would be within the wEditor.Application.Documents collection, though it was typically the first one), I created an almost-certainly unique piece of text and assigned it to the body of the email, which I could then go and find. Here's the new code that I added to the code above:
Dim aDoc As Word.Document
Dim strUniqueID As String
. . .
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
strUniqueID = accessApp.Forms![ProcessStatus].lblSubject.Caption & Rnd(Now()) & Now()
mail.Body = strUniqueID
' Search for the unique text. aDoc.Content has extra characters at the
' end, so compare only for the length of the unique text
For Each aDoc In wEditor.Application.Documents
If Left(aDoc.Content, Len(strUniqueID)) = strUniqueID Then
aDoc.Select
mail.Body = ""
End If
Next aDoc
wEditor.Application.Selection.TypeText Text:="Test"
. . .
I looked at a lot of examples of code that did this kind of thing. None of them performed a select or said anything about needing one. Debugging was made that much harder because the select occured implicitly when the debugger was invoked.

Extract AddressEntry object details for Exchange User

Is there a way to extract the details in this dialog box via VBA?
Details Dialog Box http://i.msdn.microsoft.com/dynimg/IC84336.gif
I need, especially the content in the E-Mail address tab.
You can pretty much get the fields easily, the E-mail Addresses is the harder part. References: Microsoft Exchange Property Tags
This code exports some details but most importantly the Email addresses to a text file.
Sub ListGAL()
On Error Resume Next
Const LogFile = "C:\Test\OLK_GAL.log"
Const sSCHEMA = "http://schemas.microsoft.com/mapi/proptag/0x"
Const PR_EMS_AB_PROXY_ADDRESSES = &H800F101E
Dim oNameSpace As NameSpace, oGAL As AddressList, oEntry As AddressEntry
Dim oFSO As Variant, oLF As Variant, oExUser As ExchangeUser, i As Long
' Oulook objects
Set oNameSpace = Outlook.Application.GetNamespace("MAPI")
' Global Address List object
Set oGAL = oNameSpace.AddressLists("Global Address List")
'----------
' Log file objects
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oLF = oFSO.CreateTextFile(LogFile)
'----------
For Each oEntry In oGAL.AddressEntries
i = i + 1
Debug.Print i & vbTab & oEntry.Name
If oEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
oLF.WriteLine "Entry " & i & " (olExchangeUserAddressEntry)"
oLF.WriteLine "Name: " & oEntry.Name
oLF.WriteLine "Address: " & oEntry.Address
Set oExUser = oEntry.GetExchangeUser
' SMTP ADDRESSES
oLF.WriteLine "SMTP Addresses:"
oLF.WriteLine vbTab & Join(oExUser.PropertyAccessor.GetProperty(sSCHEMA & Hex(PR_EMS_AB_PROXY_ADDRESSES)), vbCrLf & vbTab)
Set oExUser = Nothing
oLF.WriteLine String(50, Chr(151)) ' Separator
End If
Next
'----------
' Close Log File, clean up
oLF.Close
Set oGAL = Nothing
Set oNameSpace = Nothing
Set oLF = Nothing
Set oFSO = Nothing
End Sub
i have go a function of reading the address-book:
Function Get_mail(Absender As String)
Dim OutApp As Outlook.Application
Dim OutTI As Outlook.TaskItem
Dim OutRec As Outlook.Recipient
Set OutApp = New Outlook.Application
Set OutTI = OutApp.CreateItem(3)
OutTI.Assign
Set OutRec = OutTI.Recipients.Add(Absender)
OutRec.Resolve
If OutRec.Resolved Then
On Error GoTo exit_function
Get_mail = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
exit_function: Exit Function
Set OutApp = Nothing
Set OutTI = Nothing
End Function
as far as I know you can only read out the Primary Mail-address from the mail-addresses-tab; to see what else there ist delete the part ".PrimarySmtpAddress", mahe the dot and you should get the list of other properties.
I am quite sure you need the reference on Microsoft Outlook 14.0 Object Library.
The Input "Absender" can be any string . if this string can be resolved as address book-entry in an outlook-mail, you will also have a positive result from the code above.
To call the function, if for example you have a string "mail_adress_from_adressbook" you would put:
mail_adress_from_adressbook = get_mail("Joe Smith")
I hope this helps,
Max
Sure, you can access any GAL object property shown by Outlook (and then some) even if the properties are not explicitly exposed by the AddressEntry or ExchangeUser objects using AddressEntry.PropertyAccessor.GetProperty as long as you know the MAPI property's DASL name
The DASL property names can be retrieved using OutlookSpy (I am its author): either click IAddrBook button to drill down to a particular address entry or, if you have a message addressed to one of the GAL recipients, click IMessage button, go to the GetRecipientTable tab, double click on the recipient to open it as IMailUser:
In your particular case, you need PR_EMS_AB_PROXY_ADDRESSES (DASL name "http://schemas.microsoft.com/mapi/proptag/0x800F101F") - it is a multivalued string property, which means AddressEntry.PropertyAccessor.GetProperty will return an array of strings. Each value is prefixed with the address type (e.g. "EX:" or "smtp:"), the default SMTP address will be prefixed with "SMTP:" (note the upper case):
Set User = Application.session.CurrentUser.AddressEntry
AddressList = User.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x800F101F")
If IsArray(AddressList) Then
For i = LBound(AddressList) To UBound(AddressList)
MsgBox AddressList(i)
Next
End If

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"