How could we automatically/programmatically set the sender/contact image in outlook 2007? They are colleagues, and all employees pictures are stored in netshare.
I see that Outlook.ContactItem has an AddPicture method. Here's an example straight out of the help file:
Sub AddPictureToAContact()
Dim myNms As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myContactItem As Outlook.ContactItem
Dim strName As String
Dim strPath As String
Dim strPrompt As String
Set myNms = Application.GetNamespace("MAPI")
Set myFolder = myNms.GetDefaultFolder(olFolderContacts)
strName = InputBox("Type the name of the contact: ")
Set myContactItem = myFolder.Items(strName)
If myContactItem.HasPicture = True Then
strPrompt = MsgBox("The contact already has a picture associated with it. Do you want to overwrite the existing picture?", vbYesNo)
If strPrompt = vbNo Then
Exit Sub
End If
End If
strPath = InputBox("Type the file name for the contact: ")
myContactItem.AddPicture (strPath)
myContactItem.Save
myContactItem.Display
End Sub
Related
Dear StackOverflowers.
I know a few programming languages, but unfortunately VBA is not one of them.
I'm trying to make a script that saves the headers from selected mails in Outlook as .msg-files.
I found a script that opens the headers as new messages, but how to I save them as e.g. [senders domain]_[date recieved].msg instead of opening them as new mails?
The script that I have:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author: BlueDevilFan'
' //techniclee.wordpress.com/
' Outlook: 2007'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
Use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. For example:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
So you want an MSG file that has no recipients, attachments, subject, etc, only the MIME headers as the body? Why do you want the MSG format then?
You can create an populate a text file using the Scripting.FileSystemObject and use its CreateTextFile method.
Thank you, Eugene.
I managed to put in your code.
But it doesn't give the file a name, it's only called ".msg", and it doesn't work, when I try to select more than one email.
Also, how do I avoid, that it opens a new mail with the header?
I have this script now:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.SenderEmailAddress
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.saveas "C:\temp\" & strname & ".msg", OLTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
I am really new to VBA, was trying to play around with really basic things, userform and vlookup. Couldn't figure out vlookup error after many hours. Appreciate any input!
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdSend_Click()
' emailcommand Macro
'
Dim oApp As Outlook.Application
Dim oMail As MailItem
Set oApp = New Outlook.Application
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = emailaddress.Value
.Subject = Subjectbox.Value
.Body = "Hi, " & Fundname.Value & " is ready"
.Display
Application.SendKeys "%s"
End With
End Sub
Private Sub Fundnumber_Change()
Dim ws As Worksheet
Set ws = Sheets("Matrix")
With Me
.Fundname.Text = Application.VLookup(.Fundnumber.Text, ws.Range("A2:D141"), 4, False)
End With
End Sub
I have a requirement to copy all the sub folders (along with the test sets within them) as sub folders under another test set folder
for eg., lets say i have test set folder
Root\TestSetFolder1
===TestsetSubfolder1
----testset1
---- testset2
====TestSetSubFolder2
-----testset3
----- testset4
i want all of the subfolders and test sets within those folders to be copied under a new test set folder location ,for eg
Root\TestSetFolder2
so after copy the destination folder should have
Root\TestSetFolder2
===TestsetSubfolder1
----testset1
---- testset2
====TestSetSubFolder2
-----testset3
----- testset4
here is the code`enter code here
how do i recursively copy only the subfolders
** Dim tdc, qcServer
Set tdc = CreateObject("TDApiOle80.TDConnection")
qcServer = "http://server.com"
tdc.InitConnectionEx qcServer
Dim qcUsername As String
Dim qcPassword As String
Dim qcDomain As String
Dim qcProject As String
Dim treeMng As TestSetTreeManager
Dim sourceFolder As testSetFolder
Dim destFolder As testSetFolder
Dim iscp As ISupportCopyPaste
Dim clipboard As String
qcUsername =InputBox("Enter QC User Name")
qcPassword = InputBox("Enter QC password")
tdc.Login qcUsername, qcPassword
If (tdc.LoggedIn = false) Then
MsgBox "QC User Authentication failed", vbInformation, "User Authentication"
End If
qcDomain = "FS1"
qcProject = "FQA1"
tdc.Connect qcDomain, qcProject
If (tdc.Connected = failed) Then
MsgBox ("QC Project not connected :" & qcProject), vbInformation, "Project Connection"
End If
call CopyPasteTestSetFolder("Root\F1\F3\F4","Root\F7\test_vb2")
Private Sub CopyPasteTestSetFolder(sourceFolderPath, destFolderPath)
Dim treeMng
Dim sourceFolder
Dim destFolder
Dim iscp
Dim clipboard
Set treeMng = tdc.TestSetTreeManager
Set sourceFolder = treeMng.NodeByPath(sourceFolderPath)
Set destFolder = treeMng.NodeByPath(destFolderPath)
Set iscp = sourceFolder
clipboard = iscp.CopyToClipBoard(sourceFolder.NodeID, 0, sourceFolderPath)
Set iscp = destFolder
iscp.PasteFromClipBoard clipboard, destFolder.NodeID, 0, -1
Set treeMng = Nothing
Set sourceFolder = Nothing
Set destFolder = Nothing
Set iscp = Nothing
End Sub `**
This is giving object is required 424 error at "Set treeMng = tdc.TestSetTreeManager " line
I've been working quickly on a little script so that I can set and remove networks drives or create folders depending on a persons group membership, it doesn't seem to work and there are no error messages, could do with a second pair of eyes, I'd really appreciate it!
DIM CHS
SET CHS = CreateObject("Scripting.FileSystemObject")
SET CHSshell = CreateObject("WScript.Shell")
SET CHSnetwork = CreateObject("WScript.Network")
PRIVATE FUNCTION isMember( Group )
SET netCHS = CreateObject("WScript.Network")
Domain = netCHS.UserDomain
User = netCHS.UserName
isMember = false
SET userCHS = GetObject("WinNT://" & Domain & "/" & User & ",user")
FOR EACH Group in userCHS.Groups
IF (Group.Name = GroupName) THEN
isMember = true
EXIT FOR
END IF
NEXT
SET userCHS = NOTHING
SET netCHS = NOTHING
END FUNCTION
SET CHS = NOTHING
IF ( isMember("Domain Admins") = "True" ) THEN
CHSnetwork.RemoveNetworkDrive "z:"
WSript.Echo "CHSnetwork.UserName"
END IF
You call
isMember("Domain Admins")
The function
PRIVATE FUNCTION isMember( Group )
picks up the parameter in the name Group. But you (re/mis-)use Group in
FOR EACH Group in userCHS.Groups
to loop over the userCHS.Groups and in
IF (Group.Name = GroupName) THEN
to get the .Name to compare with GroupName. Where does GroupName come from?. Try to change the function's header to
PRIVATE FUNCTION isMember( GroupName )
and consider to use Option Explicit to avoid such mistakes.
This VBS script will show all groups the user belong to:
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim oNetwork: Set oNetwork = CreateObject("WScript.Network")
Dim sUserName: sUserName = oNetwork.UserDomain & "/" & oNetwork.UserName
sUserName = InputBox("Windows User Name","Enter Windows User Name", sUserName)
If sUserName <> "" Then
GetGroups
End If
Sub GetGroups
Const ADS_READONLY_SERVER = 4
Dim oGroup, oUser
Dim oShell: Set oShell = Wscript.CreateObject("WScript.Shell")
Dim sFolderPath: sFolderPath = GetFolderPath()
Dim oNS: Set oNS = GetObject("WinNT:")
Dim oList: Set oList = CreateObject("System.Collections.ArrayList")
Dim sFilePath: sFilePath = sFolderPath & "\" & Replace(Replace(sUserName,"\","-"),"/","-") & "_groups.txt"
Set oUser = oNS.OpenDSObject("WinNT://" & sUserName, "", "", ADS_READONLY_SERVER)
For Each oGroup In oUser.groups
oList.Add oGroup.Name
Next
oList.Sort()
Dim oLog: Set oLog = fso.CreateTextFile(sFilePath, True)
For Each sItem in oList
oLog.Write sItem & vbCrLf
Next
oLog.Close
oShell.Run sFilePath
End Sub
Function GetFolderPath()
Dim oFile 'As Scripting.File
Set oFile = fso.GetFile(WScript.ScriptFullName)
GetFolderPath = oFile.ParentFolder
End Function
My marketing department, bless them, has decided to make a sweepstakes where people enter over a webpage. That is great but the information isn't stored to a DB of any sort but is sent to an exchange mail box as an email. Great.
My challenge is to extract the entry (and marketing info) from these emails and store them someplace more useful, say a flat file or CSV. The only saving grace is that the emails have a highly consistant format.
I am sure I could spend the time saving all the emails to files and then write an app to munge through them all but was hoping for a much more elegant solution. Can I programmatically access an exchange mailbox, read all the emails and then save that data?
Here is the code I used....
Private Sub btnGo_Click()
If ComboBox1.SelText <> "" Then
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objMail As mailItem
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
For Each objFolder In objInbox.Folders
If (objFolder.Name = ComboBox1.SelText) Then
Set objInbox = objFolder
End If
Next objFolder
//Loop through the items in the Inbox
Dim count As Integer
count = 1
For Each objMail In objInbox.Items
lblStatus.Caption = "Count: " + CStr(count)
If (CheckBox1.Value = False Or objMail.UnRead = True) Then
ProcessMailItem (objMail.Body)
count = count + 1
objMail.UnRead = False
End If
Next objMail
End If
End Sub
Private Sub ProcessMailItem(strBody As String)
Open "C:\file.txt" For Append As 1
Dim strTmp As String
strTmp = Replace(strBody, vbNewLine, " ")
strTmp = Replace(strTmp, vbCrLf, " ")
strTmp = Replace(strTmp, Chr(13) & Chr(10), " ")
strTmp = Replace(strTmp, ",", "_")
//Extra Processing went here (Deleted for brevity)
Print #1, strTmp
Close #1
End Sub
Private Function Strip(strStart As String, strEnd As String, strBody As String) As String
Dim iStart As Integer
Dim iEnd As Integer
iStart = InStr(strBody, strStart) + Len(strStart)
If (strEnd = "xxx") Then
iEnd = Len(strBody)
Else
iEnd = InStr(strBody, strEnd) - 1
End If
Strip = LTrim(RTrim(Mid(strBody, iStart, iEnd - iStart)))
End Function
Private Sub UserForm_Initialize()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objFolder As MAPIFolder
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
//Loop through the folders under the Inbox
For Each objFolder In objInbox.Folders
ComboBox1.AddItem objFolder.Name
Next objFolder
End Sub
There's lots of different ways to get at the messages in an exchange mailbox, but since it seems this is something you're only going to want to run once to extract the data I'd suggest writing a VBA macro to run inside Outlook itself (having opened the exchange mailbox in question within Outlook). It's pretty easy to iterate through the mail items in a specific mailbox and read the body text from them. You can then write a text file with just the stuff you want.