PDA

View Full Version : Solved: Copy cell range, paste into Outlook Contact Notes



xjetjockey
01-09-2009, 08:39 AM
I have a routine that creates an Outlook contact from the Excel data. I am trying to find out how to copy a range of cells and then paste that (or any other way that will preserve the formatting) into the notes section of the contact that I'm creating. It's a piece of cake to manually copy and paste, but for the life of me I can't figure this out. Thanks.


Sub MakeContact()
'Makes a new Outlook contact from the Prospect Data on "Main" sheet
Dim olApp As outlook.Application
Dim olCi As outlook.ContactItem
Dim PText As String
Dim PropText As String
Dim NotesText As String

Set olApp = New outlook.Application
Set olCi = olApp.CreateItem(olContactItem)

NotesText = VBA.Date & " Proposal History Information" & vbNewLine & vbNewLine
PText = ""
PropText = MsgBox("Do you want to include the current proposal text in your Outlook notes section?" _
& vbNewLine & "This action will retrieve the body text of the currently prpared proposal." _
& vbNewLine & "Click Cancel if you need to prepare the proposal.", vbYesNoCancel + vbQuestion, "Include Proposal Text?")
If PropText = vbYes Then
PText = Sheet15.Range("A17").Value
NotesText = NotesText & "Proposal Text" & vbNewLine & PText & vbNewLine & vbNewLine
End If
If PropText = vbCancel Then
Exit Sub
End If

With olCi
.FirstName = Sheets("Main").tbFIRSTNAME.Value
.Body = "Contact Added " & VBA.Date & vbNewLine & vbNewLine & NotesText & vbNewLine & vbNewLine

'CODE GOES HERE TO COPY AND PASTE A RANGE OF CELLS FROM WORKSHEET TO CONTACT NOTES SECTION?
'APPEND TO EXISTING NOTES

.COMPANYNAME = Sheets("Main").tbCOMPANYNAME.Value
.LastName = Sheets("Main").tbLASTNAME.Value
.BusinessTelephoneNumber = Sheets("Main").tbPHONE.Value
.BusinessFaxNumber = Sheets("Main").tbFAX.Value
.Email1Address = Sheets("Main").tbCONTACTEMAIL.Value
.BusinessAddressCity = Sheets("Main").tbCITY.Value
.BusinessAddressStreet = Sheets("Main").tbADDRESS.Value
.BusinessAddressState = Sheets("Main").tbSTATE.Value
.BusinessAddressPostalCode = Sheets("Main").tbZIP.Value
.SelectedMailingAddress = olBusiness
.Categories = "Business"
'.Save
.Display
End With

Set olCi = Nothing
Set olApp = Nothing

End Sub

Kenneth Hobs
01-09-2009, 10:43 PM
I don't know but for plain text:
Sub MakeContact()
'Add Reference: Tools > References > Microsoft Outlook 11.0 Object Library
'Add Reference: Tools > References > Microsoft Forms 2.0 Object Library
'Makes a new Outlook contact from the Prospect Data on "Main" sheet
Dim olApp As Outlook.Application
Dim olCi As Outlook.ContactItem
Dim PText As String
Dim PropText As String
Dim NotesText As String
Dim objData As DataObject
Dim varBody As String

Set olApp = New Outlook.Application
Set olCi = olApp.CreateItem(olContactItem)
Set objData = New DataObject

NotesText = VBA.Date & " Proposal History Information" & vbNewLine & vbNewLine
PText = ""
PropText = MsgBox("Do you want to include the current proposal text in your Outlook notes section?" _
& vbNewLine & "This action will retrieve the body text of the currently prpared proposal." _
& vbNewLine & "Click Cancel if you need to prepare the proposal.", vbYesNoCancel + vbQuestion, "Include Proposal Text?")
If PropText = vbYes Then
PText = Sheet1.Range("A17").Value
NotesText = NotesText & "Proposal Text" & vbNewLine & PText & vbNewLine & vbNewLine
End If
If PropText = vbCancel Then
Exit Sub
End If

With olCi
.FirstName = Sheets("Main").tbFIRSTNAME.Value
.Body = "Contact Added " & VBA.Date & vbNewLine & vbNewLine & NotesText & vbNewLine & vbNewLine

'CODE GOES HERE TO COPY AND PASTE A RANGE OF CELLS FROM WORKSHEET TO CONTACT NOTES SECTION?
'APPEND TO EXISTING NOTES
Range("A1").Value = "Hello"
Range("A1").Font.ColorIndex = 3 'Not copied!
Range("A2").Value = "World!"
Range("A1:A2").Copy
objdata.GetFromClipboard
varBody = objData.GetText
.Body = .Body & varBody

.COMPANYNAME = Sheets("Main").tbCOMPANYNAME.Value
.LastName = Sheets("Main").tbLASTNAME.Value
.BusinessTelephoneNumber = Sheets("Main").tbPHONE.Value
.BusinessFaxNumber = Sheets("Main").tbFAX.Value
.Email1Address = Sheets("Main").tbCONTACTEMAIL.Value
.BusinessAddressCity = Sheets("Main").tbCITY.Value
.BusinessAddressStreet = Sheets("Main").tbADDRESS.Value
.BusinessAddressState = Sheets("Main").tbSTATE.Value
.BusinessAddressPostalCode = Sheets("Main").tbZIP.Value
.SelectedMailingAddress = olBusiness
.Categories = "Business"
'.Save
.Display
End With

Set olCi = Nothing
Set olApp = Nothing
Set objData = Nothing

End Sub

xjetjockey
01-10-2009, 09:50 AM
Thanks for your help. That works, but not quite what I'm after. I tried the manual process again, and what it does is it actually pastes the cells along with the content so what you end up with is a mini-spreadsheet object in the notes section of the contact. When it does that it retains the layout and all the formatting.

lucas
01-10-2009, 10:35 AM
xjet,
Outlook is not something I'm very familiar with but this works for copying and pasting formatted text from excel to word so you might investigate pastespecial as rtf.....

Private Sub ComboBox1_Change()
ExcelBook.Sheets(1).Range(ComboBox1.Column(1)).Copy
Selection.PasteSpecial DataType:=wdPasteRTF
End Sub


I don't have a solution but thought I would throw that out there for your consideration.

Kenneth Hobs
01-10-2009, 10:45 AM
The only way that I know to do it would be Sendkeys. If you are using Vista, you have to disable UAC for SendKeys to work. If this interests you, post back.

xjetjockey
01-12-2009, 12:54 PM
Sure, I'm interested. At at a dead end at the moment. Not using Vista.

Kenneth Hobs
01-12-2009, 09:25 PM
I will look into it tomorrow. Just remembered that you wanted to explore that path.

Kenneth Hobs
01-13-2009, 08:53 PM
Your mileage may vary due to timing and focus. These are often issues with SendKeys.
Sub MakeContact()
'Add Reference: Tools > References > Microsoft Outlook 11.0 Object Library
'Add Reference: Tools > References > Microsoft Forms 2.0 Object Library
'Makes a new Outlook contact from the Prospect Data on "Main" sheet
Dim olApp As Outlook.Application
Dim olCi As Outlook.ContactItem
Dim PText As String
Dim PropText As String
Dim NotesText As String
Dim objdata As DataObject
Dim varBody As String
Dim t2 As Double

Set olApp = New Outlook.Application
Set olCi = olApp.CreateItem(olContactItem)
Set objdata = New DataObject

NotesText = VBA.Date & " Proposal History Information" & vbNewLine & vbNewLine

With olCi
.Body = "Contact Added " & VBA.Date & vbNewLine & vbNewLine & NotesText & vbNewLine & vbNewLine

'CODE GOES HERE TO COPY AND PASTE A RANGE OF CELLS FROM WORKSHEET TO CONTACT NOTES SECTION?
'APPEND TO EXISTING NOTES
Range("A1").Value = "Hello"
Range("A1").Font.ColorIndex = 3 'Not copied!
Range("A2").Value = "World!"
Range("A1:A2").Copy
objdata.GetFromClipboard
varBody = objdata.GetText
'.Save
.Display (False)
AppActivate "Untitled - Contact"
SendKeys "%W", True
SendKeys "{Tab 3}", True 'Make Body active
SendKeys "^{End}", True 'Go to end of Body
SendKeys "+{Insert}", True 'Paste copied cells
Application.CutCopyMode = False
End With
Set olCi = Nothing
Set olApp = Nothing

End Sub

xjetjockey
02-19-2009, 03:35 PM
Thanks for your help. I didn't actually try it because I went down a different road that ended up working quite nicely. This code will create the contact and past the info into the body of the contact. It runs on 2007. I have had an unusual problem where it won't do the paste part for some reason. I've discovered that for some odd reason, still unresolved, the antivirus program seems to prevent it. I actually uninstalled the antivirus program (AVG, and also same problem with Avast), and it works every time. Here's the code:

Sub MakeContact()
'Makes a new Outlook contact
Dim olApp As outlook.Application
Dim olCi As outlook.ContactItem
Dim NotesText As String
Dim wsnew As Worksheet
Dim MailDoc As Word.Document
Dim BodyRange As Word.Range

Set olApp = New outlook.Application
Set olCi = olApp.CreateItem(olContactItem)

With olCi
.FirstName = "Bill"
.COMPANYNAME = "United Terrorists Assoc."
.LastName = "Ayers"
.BusinessTelephoneNumber = "666-666-6666"
.BusinessFaxNumber = "666-666-6613"
.Email1Address = "ayers@fu.com"
.BusinessAddressCity = "Hell"
.BusinessAddressStreet = "Pipe Bomb Ave."
.BusinessAddressState = "PA"
.BusinessAddressPostalCode = "65432"
.SelectedMailingAddress = olBusiness
'.Save
.Display
End With

NotesText = VBA.Date & " Proposal History Information" & vbNewLine
NotesText = NotesText & "Proposal Text" & vbNewLine & Sheet1.Range("A22").Value & vbNewLine

Set wsnew = ActiveWorkbook.Sheets.Add
Range("A1:G1").Select
With Selection
.WrapText = True
.MergeCells = True
End With
wsnew.Range("A1").Value = "Contact Added " & VBA.Date & vbNewLine
Range("A2:G2").Select
With Selection
.WrapText = True
.MergeCells = True
End With
wsnew.Range("A2").Value = NotesText
Sheet1.Activate
Sheet1.Range("A1:G17").Copy wsnew.Range("A3")
wsnew.Activate
wsnew.Columns.EntireColumn.AutoFit
Set MailDoc = outlook.Application.ActiveInspector.WordEditor
Set BodyRange = MailDoc.Range
wsnew.UsedRange.Copy
BodyRange.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
wsnew.Delete
Application.DisplayAlerts = True
Set olCi = Nothing
Set olApp = Nothing
End Sub