Trying to create a simple routine to modify a shortcut target path. I found an outdated shell reference that I was hoping to tweak.
It's assumed that the shortcut lives on the user's desktop. The plan is to call it like this ChangeShortcut "Test.lnk", "C:/users/environ$("username") & "/" & OneDrive-Personal/DBFolder/PMD_FE.accdb"
The following routine gets stuck at objfolder.ParseName(strNameOfShortCut) here is the complete routine:
Public Sub ChangeShortcut(strNameOfShortCut As String, strNewShortcutTarget As String)
Const ALL_USERS_DESKTOP = &H19&
Dim objShell As Object 'shell As Shell32.shell
Dim objfolder As Object 'Shell32.folder
Dim objfolderItem As Object 'Shell32.folderItem
Dim objShortcut As Object 'Shell32.ShellLinkObject
Dim objShellLink As Object
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.Namespace(ALL_USERS_DESKTOP)
If Not objfolder Is Nothing Then
Set objfolderItem = objfolder.ParseName(strNameOfShortCut)
If Not objfolderItem Is Nothing Then
Set objShortcut = objfolderItem.GetLink
If Not objShortcut Is Nothing Then
objShortcut.Path = strNewShortcutTarget 'To Change
objShortcut.Save
MsgBox "Shortcut changed"
Else
MsgBox "Shortcut link within file not found"
End If
Else
MsgBox "Shortcut file not found"
End If
Else
MsgBox "Desktop folder not found"
End If
End Sub
This worked for me. For some reason I could not get ParseName to work, but looping the desktop items and checking for the name was ok.
Sub Tester()
ChangeShortcut "Test.lnk", "C:\Temp\Docs"
End Sub
Public Sub ChangeShortcut(strNameOfShortCut As Variant, strNewShortcutTarget As Variant)
Const DESKTOP = &H10&
Dim objShell As Object 'shell As Shell32.shell
Dim objfolder As Object 'Shell32.folder
Dim objfolderItem As Object 'Shell32.folderItem
Dim objShortcut As Object 'Shell32.ShellLinkObject
Dim objShellLink As Object, itm As Object, ok As Boolean
Set objShell = CreateObject("Shell.Application")
Set objfolder = objShell.Namespace(DESKTOP)
If Not objfolder Is Nothing Then
For Each itm In objfolder.items
If itm.Name = strNameOfShortCut Then
ok = True
Set objShortcut = itm.GetLink
If Not objShortcut Is Nothing Then
objShortcut.Path = strNewShortcutTarget 'To Change
objShortcut.Save
ok = True
MsgBox "Shortcut changed"
Else
MsgBox "Shortcut link within file not found"
End If
End If
Next itm
If Not ok Then MsgBox "Shortcut file not found"
Else
MsgBox "Desktop folder not found"
End If
End Sub
Related
I can move emails to my file system. Is it possible to do the reverse? This is what I have tried:
Sub GetMSG()
Dim StrFolder As String
StrFolder = "G:\CP-Purchasing\Completed Projects"
ListFilesInFolder StrFolder, True 'True includes subfolders, false check only this folder
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim FileItem As Scripting.File
Dim strFile, strFileType
Dim MyMsg As MailItem
Dim FolderPick As Folder
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Set FolderPick = Application.GetNamespace("MAPI").PickFolder
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
' This code looks at the last 4 characters in a filename
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set MyMsg = Application.CreateItemFromTemplate(FileItem.Path)
MyMsg.SaveAs (FolderPick)'This does not error, but also does not seem to work
MyMsg.Move (FolderPick)'This errors
Set objAttachments = Nothing
Set MyMsg = Nothing
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
On MyMsg.SaveAs (FolderPick) I get no error message, but it also does not save the msg in the specified folder.
MyMsg.Move (FolderPick) errors with
run-time error 424 "Object required".
For further processing after the move, you need another object since the reference to myMsg is lost.
Set myCopiedMsg = myMsg.Move(folderPick)
Debug.Print myCopiedMsg.Parent.FolderPath
In your code for moving only:
' no brackets
myMsg.Move folderPick
I want to add user to an existing DL using outlook VBA. For example. I have a DL which has email id as "testdl#contoso.com" and want add an existing user name "John.Wick#contoso.com". I also know that I can use DistListItem.AddMember to add user to an existing DL. But I am getting idea to find the existing distribution list. Please help me with this.
Sub Add_User_To_DL()
Dim myNameSpace AS Outlook.NameSpace
Dim myFolder AS Outlook.Folder
Dim myDistList AS Outlook.DistListItem
Dim myFolderItems AS Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
myFolder.Display
End Sub
But this code just opens Contacts group window. What I want is , to open the specified DL and then add specified member to DL.
To find a distribution list that includes a specific address.
Option Explicit
Sub Find_ContactGroup_Given_Member()
Dim ContactGroup As String
Dim objItem As Object
Dim objContactsFolder As Folder
Dim i As Long
Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
For Each objItem In objContactsFolder.Items
If TypeOf objItem Is DistListItem Then
Debug.Print objItem.DLName
For i = 1 To objItem.MemberCount
If objItem.GetMember(I).Address = "testdl#contoso.com" Then
Debug.Print objItem.GetMember(i).Name
objItem.Display
End If
Next i
End If
Next
End Sub
To reference a distribution list:
Option Explicit
Sub DistListDisplay()
Dim strDistListName As String
Dim objItem As Object
Dim objContactsFolder As Folder
Dim objContactGroup As DistListItem
Dim bFound As Boolean
strDistListName = InputBox("Name of an existing distribution list.", , "Test")
If Len(strDistListName) = 0 Then Exit Sub ' Cancel
Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
For Each objItem In objContactsFolder.Items
If TypeOf objItem Is DistListItem Then
If objItem.DLName = strDistListName Then
Set objContactGroup = objItem
With objContactGroup
.Display
bFound = True
Exit For
End With
End If
End If
Next
If bFound = False Then
MsgBox strDistListName & " not found."
End If
End Sub
I am looking for a VBA Script to automatically add a public folder to the "Favorites" folder in Outlook 365 (to add it as a GPO later). I have found multiple scripts such as this one:
' path to public folder; should be similar to
' "Public Folders\All Public Folders\Company\Sales"
strFolder = "\\Public Folders - gabriel.buehler#wingd.com\All Public Folders\Local Winterthur Holidays"
Call AddFolderToFavorites(strFolder, True)
Sub AddFolderToFavorites(strPath, AddToAddressBook)
Const olContactItem = 2
Set myFolder = GetFolder(strPath)
If Not myFolder Is Nothing Then
myFolder.AddToPFFavorites
' if contacts folder,
' optionally add new Favorite to OAB
If myFolder.DefaultItemType = olContactItem Then
If AddToAddressBook = True Then
strFavFolder = _
"Public Folders\Favorites\" & _
myFolder.Name
Set myFavFolder = GetFolder(strFavFolder)
If Not myFavFolder Is Nothing Then
myFavFolder.ShowAsOutlookAB = True
End If
End If
End If
End If
Set myFolder = Nothing
End Sub
Public Function GetFolder(strFolderPath)
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
To be honest: I have not used VBA before, so I don't know if the code itself is correct...but When I start to run the script, it always pops up a window where I should ad a "Macro Name":
When I enter In a macro name and press "run" it says "Compile Error Invalid Outside Procedure".
Can you tell me what I am doing wrong here?
You can manage the Outlook favorites group by accessing the NavigationPane module.
Dim mailModule as Outlook.MailModule
Set mailModule = Application.ActiveExplorer().NavigationPane.Modules.GetNavigationModule(Outlook.OlNavigationModuleType.olModuleMail)
Dim favGroup as Outlook.NavigationGroup
Set favGroup = ailModule.NavigationGroups.GetDefaultNavigationGroup(Outlook.OlGroupType.olFavoriteFoldersGroup)
favGroup.NavigationFolders.Add(objFolder)
Read more about that in the Add a Folder to the Favorite Folders Group article.
Also, you may find the Folder.AddToPFFavorites method which adds a Microsoft Exchange public folder to the public folder's Favorites folder helpful.
is there a way Outlook automatically runs a macro whenever I get an email that goes to a specific folder in Outlook (just to clarify, the email goes there because I have set up a rule, so instead of going to my inbox it goes to that folder).
I think I would need code that detects whenever my folder receives an new email and then automatically runs the macro.
My code is the following, I execute test, which executes SaveEmailAttachmentsToFolder.
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox 'Arg 2 = File extension, "" is every file 'Arg 3 = Save folder, "C:\Users\Ron\test" or "" ' If you use "" it will create a date/time stamped folder for you in your "Documents" folder ' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "Dependencia Financiera", "xls", "V:\Dependencia Financiera\Dependencia Financiera\"
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _ ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As Folder
Dim SubFolder As Folder
Dim subFolderItems As Items
Dim Atmt As Attachment
Dim FileName As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
Set subFolderItems = SubFolder.Items
If subFolderItems.Count > 0 Then
subFolderItems.Sort "[ReceivedTime]", True
For Each Atmt In subFolderItems(1).Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
End If
' Clear memory ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set subFolderItems = Nothing
End Sub
seulberg1 told me to use the follwing code how, should my paste my own code since, it has 2 Subs.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup() Dim olApp As Outlook.Application
Set olApp = Outlook.Application Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Add your code here
ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace Set GetNS = app.GetNamespace("MAPI") End Function
Thanks you in advance !!!
This code (adapted from Jimmy Pena) should do the trick.
It initiates the event listener on Outlook startup and checks the folder "Your Folder Name" for new emails. It then performs a designatable action at the ("Add your code here") section.
Let me know if this helps
Best regards
seulberg1
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
**'Add your code here**
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
got a little problem, I hope someone can help me.
(Outlook 2010 VBA)
this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place)
it has to check if the Sender of the mail is already in my contacts or in the
Addressbook 'All Users',
and if it's not a one of those yet, open the AddContact window and fill in his/her information
what doesn't work yet is:
most important of all, it doesn't run the script when i click on a mail
the current check if the contact already exsist doesn't work
and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need
if the contact already exsist then nothing has to happen.
I hope i gave enough information and someone can help me out here :)
Sub AddAddressesToContacts(objMail As Outlook.MailItem)
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
''don't want or need a vbBox/ask box, this is a part of the current contactcheck
''wich doesn't work and is totaly wrong :P
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
bContinue = True
sSenderName = ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
''this part till the --- is wrong, i need someting to check if the contact (the sender)
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
response = vbAbort
If response = vbAbort Then
bContinue = False
End If
End If
''---------
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
'.Save
oContact.Display
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
hey, i still have a last question,
'sets the name of the contact
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
'checks if the contact exsist, if it does exit the for loop
If Not oContact Is Nothing Then
Exit For
End If
End If
this checks if the name is already in contacts,
i need it that it checks if the E-mailaddress is in contacts or not,
can you help me with that?
i had someting like this in mind
set oSendermail = ?the e-mailaddress?
If Not oSendermail Is Nothing Then
Exit For
End If
End If
A solution (including test routine) could look as follows:
(assuming that we only consider external SMTP mails. Adjust the path to your contact folder and add some more error checking!)
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub AutoContactMessageRule(newMail As Outlook.mailItem)
' "script" routine to be called for each incoming Mail message
' This subroutine has to be linked to this mail type using
' Outlook's rule assistant
Dim EntryID As String
Dim StoreID As Variant
Dim mi As Outlook.mailItem
Dim contactFolder As Outlook.Folder
Dim contact As Outlook.ContactItem
On Error GoTo ErrorHandler
' we have to access the new mail via an application reference
' to avoid security warnings
EntryID = newMail.EntryID
StoreID = newMail.Parent.StoreID
Set mi = Application.Session.GetItemFromID(EntryID, StoreID)
With mi
If .SenderEmailType = "SMTP" Then
Set contactFolder = FindFolder("Kemper\_local\TestContacts")
Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34))
If Not TypeName(contact) <> "Nothing" Then
Set contact = contactFolder.items.Add(olContactItem)
contact.Email1Address = .SenderEmailAddress
contact.Email1AddressType = .SenderEmailType
contact.FullName = .SenderName
contact.Save
End If
End If
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "Ooops!"
Err.Clear
On Error GoTo 0
End Sub
Private Function FindFolder(path As String) As Outlook.Folder
' Locate MAPI Folder.
' Separate sub-folder using '/' . Example: "My/2012/Letters"
Dim fd As Outlook.Folder
Dim subPath() As String
Dim I As Integer
Dim ns As NameSpace
Dim s As String
On Error GoTo ErrorHandler
s = Replace(path, "\", "/")
If InStr(s, "//") = 1 Then
s = Mid(s, 3)
End If
subPath = Split(s, "/", -1, 1)
Set ns = Application.GetNamespace("MAPI")
For I = 0 To UBound(subPath)
If I = 0 Then
Set fd = ns.Folders(subPath(0))
Else
Set fd = fd.Folders(subPath(I))
End If
If fd Is Nothing Then
Exit For
End If
Next
Set FindFolder = fd
Exit Function
ErrorHandler:
Set FindFolder = Nothing
End Function
Public Sub TestAutoContactMessageRule()
' Routine to test Mail Handlers AutoContactMessageRule()'
' without incoming mail messages
' select an existing mail before executing this routine
Dim objItem As Object
Dim objMail As Outlook.mailItem
Dim started As Long
For Each objItem In Application.ActiveExplorer.Selection
If TypeName(objItem) = "MailItem" Then
Set objMail = objItem
started = GetTickCount()
AutoContactMessageRule objMail
Debug.Print "elapsed " & (GetTickCount() - started) / 1000# & "s"
End If
Next
End Sub