Excel to word VBA for mail merge - excel

I have a mail merge I'm attempting to do but I can't find any information on how to update existing merge fields from VBA code. I have 10 labels on each page but each label needs to be processed as a block before moving to the next record as they have to pull from multiple columns to fill out the label. So I need to be able to replace Merge field values with what I have stored in the array. creating a new page of labels every 10 like a normal mail merge would.
I have thought about several approaches but nothing seems to be panning out for me.
I started by trying just a normal mail merge but I was only able to get the left side of the page to populate properly populating the right side causes the data to jump to the next record at the wrong time and there doesn't seem to be a way to go back a record. I couldn't find a way to process the label as a range or block.
After that I tried to reference the field codes directly. with this code but it returns an error that it's read only.
Sub OpenExcelFile()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim RowLoc As Integer
Dim ExcelArray(1 To 10000, 1 To 6) As Variant
RowLoc = 1
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("C:\Users\ScottCannon\Documents\Sticker Maker.xlsm")
oExcel.Visible = True
Do While oWB.Sheets("Barcode").Cells(RowLoc, 1) <> ""
ExcelArray(RowLoc, 1) = oWB.Sheets("Barcode").Cells(RowLoc, 1)
ExcelArray(RowLoc, 2) = oWB.Sheets("Barcode").Cells(RowLoc, 2)
ExcelArray(RowLoc, 3) = oWB.Sheets("Barcode").Cells(RowLoc, 3)
ExcelArray(RowLoc, 4) = oWB.Sheets("Barcode").Cells(RowLoc, 4)
ExcelArray(RowLoc, 5) = oWB.Sheets("Barcode").Cells(RowLoc, 5)
ExcelArray(RowLoc, 6) = oWB.Sheets("Barcode").Cells(RowLoc, 6)
RowLoc = RowLoc + 1
Loop
RowLoc = 1
ActiveDocument.MailMerge.DataSource.DataFields("Job_Name").Value = ExcelArray(RowLoc, 1) 'this part specifically doesn't work.
oWB.Close
Excel.Application.Quit
End Sub
I tried to see if there was a way to create references I can replace, but it seems like if I managed to do that it would only work for a single page. This seems so stupid it should let you group cells together as a single object or something.

I just solved my own problem. creating the labels as normal (with each label being it's own cell of a table.) I can insert a table into each cell and that will allow each label to have completely customizable formatting while still treating each label individually. So I can insert the barcode I need and the company logo without worry that text from other areas is going to screw up the formatting.

Related

Can't insert pictures in Excel with VBA

I am getting completely crazy about this issue, please help me.
I have made a shell script that writes in a text file the path of some images that are stored in a folder. Then I use an excel code to read each path and write it in an excel cell.
I have then made a code that should take that path and use it to insert the picture. I have tried with Pictures.insert(path) and shapes.addpictures "path", but I have the same issue every time, the picture can't be loaded.
What's weird, is that, if I manually insert the picture before and then delete it, the code will perfectly load the picture. But if it's the first time then no.
The paths that I'm using look like that: "/Users/theodorebedos/Documents/code_tilly/new_pict_tilly/IMG_9040.jpg"
I'm using a mac, maybe that matters?
Private Sub Convert_Img()
Dim myPict As Picture
Dim PictureLoc As String
Dim EndPictRow, i As Integer
Dim StartPath As String
If Worksheets("Main").Cells(3, 1).Value <> "" Then
EndPictRow = Worksheets("Main").Range("A2").End(xlDown).Row
For i = 3 To EndPictRow
PictureLoc = Worksheets("Main").Cells(i, 1).Value
Worksheets("Main").Cells(i, 1).ClearContents
Worksheets("Main").Cells(i, 1).ColumnWidth = 30
Worksheets("Main").Cells(i, 1).RowHeight = 150
ActiveSheet.Shapes.AddPicture PictureLoc, False, True, Worksheets("Main").Cells(i, 1).Left, Worksheets("Main").Cells(i, 1).Top, Worksheets("Main").Cells(i, 1).Width, Worksheets("Main").Cells(i, 1).Height
Next i
End If
End Sub
Edit:
When I use "Pictures.insert" or "shapes.addpicture path, true, true " I have no error message in VBA but I have in excel instead of my picture, a blank image with inside an error message like this:
image
If I use "shapes.addpicture path, FALSE, true" then I have an error message like this but no image at all is loaded: image 2
And then an error 1004 like that:
image3
And if I do the process to have image 1, then I save the document, reopen it, I'll have this directly: image 4
Thanks for you help. It will be much appreciated.
I streamlined your code so it becomes possible to see what it's doing. Note that I avoided reading values from the cell's properties which were just set or are obvious.
Once the column width has been set, the width of all cells in it are the same.
The Left property of all cells in a column is always the same.
If the column is column A, the Left is always 0.
Of course, what you tried to achieve is to enter a value only once. That is good practice but to read properties from the sheet is slow. The faster way - less code volume and better readable, too - is to declare a constant at the top and use that name in the code.
So you end up with this code.
Private Sub Convert_Img()
Const ClmWidth As Single = 30
Const RowHight As Single = 150
Dim EndPictRow As Long, R As Long
' sorry, I recommend i for arrays and R for rows (C for columns)
With Worksheets("Main")
' End(xlDown) will find the first blank cell below the base cell.
' There might be more filled cells further down.
' End(xlUp) will find the first used cell above the base cell
' disregarding more blanks above that one.
EndPictRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' no need to set the column width multiple times in the loop
.Columns(1).ColumnWidth = ClmWidth
' this loop will never run if R < EndPicRow
For R = 3 To EndPictRow
With .Cells(R, 1)
.RowHeight = RowHight
' this will work only once:-
.Worksheet.Shapes.AddPicture CStr(.Value), False, True, 0, .Top, ClmWidth, RowHight
End With
Next R
End With
End Sub
The reason why it works only once becomes quite obvious. The new picture takes its source path from the cell's Value. Of course, once you insert a picture (image) in the cell that value can't be the path (string) anymore. If you run the code a second time it will fail. However, if that is your need, it should be possible to extract the path from the formula that defines the picture in the cell. Given that the picture itself isn't present at that location the formula should either hold the path or a reference to a location within the workbook's background data, depending upon how it was loaded.
Ok, so it's not perfect yet, but I put the loop off and I used Dir() as you said #Variatus.A pop-up window like this opened when I executed the command Dir(). It asked me the authorisation to access the file. I pressed yes and then it worked.
It worked but only for that file. So I guess, I am on the right way now and I need to find how to give access to all the files in that folder before running the code. I can't do it for all of them.
Thank you very much.
I hope someone will benefit from this old thread. As it turns out this is some sort of a permission issue also noted already in one of the comments, possibly only occurring with Excel 16 macros on OSX.
It seems like Excel is lacking the permissions to access the resources linked and is not asking for them. We need to grant permissions to all files in the folder. The following code demonstrates how to achieve this, given the identifier to build the paths is in Column A2:20. Run this macro (adjust the way the path is built), then grant access once the dialogue appears:
Sub GrantAccess()
Dim cName As Variant
Dim files() As Variant
Set xRange = ActiveSheet.Range("A2:A20")
For Each cell In xRange
ReDim Preserve files(1 To cell.Row - 1)
cName = "/Users/adjust-your-path/path" & Cells(cell.Row, "A") & "_thumb_600.png"
files(cell.Row - 1) = cName
Next
fileAccessGranted = GrantAccessToMultipleFiles(files)
End Sub
Code used:
Sub URLPICInsertMM()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
Dim cName As String
Dim img As Picture
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("B2:B10")
For Each cell In xRange
'cName = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
' files are located in thumbs sub-directory
cName = "/Users/.../IonChannels/thumbs/" & Cells(cell.Row, "A") & "_thumb_300.png"
Set img = ActiveSheet.Pictures.Insert(cName)
img.Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
Cells(cell.Row, "C").Value = "file://" & cName
Set cRange = Cells(cell.Row, cell.Column)
With cShape
.LockAspectRatio = msoTrue
'If .Width > cRange.Width Then .Width = cRange.Width
If .Height > cRange.Height Then .Height = cRange.Height
.Top = cRange.Top + (cRange.Height - .Height)
.Left = cRange.Left + (cRange.Width - .Width)
End With
line22:
Set cShape = Nothing
Range("T2").Select
Next
Application.ScreenUpdating = True
End Sub
Edit:
Evidence:
I created a simple test sheet (the idea is to load some protein visualization thumbs into an excel sheet) with an identifier in Column A, image file descriptors are constructed from the identifier + path and file extension.
The image is inserted into Column B and the file descriptor as text into Column C.
When I ran the macro for the first time, only the first image was loaded. Excel formats the file descriptor as a hyperlink. When clicking the file:///... link, Excel opens a dialog that asks to grant permissions to that file (screenshot). If I grant access and accept warnings, then run the macro again, the image appears.
After running macro again, image is displayed:

Error 1004 on Resizing range and Transposing array

I will not post full code since it's quite huge - I will focus on a part that is causing an error.
The macro is supposed to copy URL's generated in excel, open them in IE, copy source code to another sheet, look for something in this code, save results in specific cell, remove sheet and go to next URL. It works quite well, it copies the source codes for many URLs, but for some URLs it just fails. When I open the URLs manually - they work perfectly, but somehow Excel throws me an error for them.
Could you guys check the below could to help me better understand where is the problem?
Here are two samples links:
This one works good - link1
This one throws error 1004 - link2
And here is the code:
Sub CC_Check()
Dim ie As InternetExplorer
Dim html As HTMLDocument
Dim URL As Range
Dim Rng As Range
Dim ws1 As Worksheet
Set ws1 = Worksheets("One Code")
Set ie = New InternetExplorer
Set Rng = ws1.Range("A3:A18")
For Each URL In Rng
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = ws1.Cells(URL.Row, 2).Value & "_" & ws1.Cells(6, 7).Value
ie.Visible = False
ie.navigate URL.Value
Do While ie.readyState <> READYSTATE_COMPLETE
DoEvents
Loop
Set html = ie.document
Range("A1").Value = html.DocumentElement.outerHTML
Dim arr
arr = Split(html.DocumentElement.outerHTML, vbLf)
Range("A1").Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr) '<-- this line causing error 1004
The Application.Transpose has a number of problems. It fails when
The array has only one member (UBound(arr) = 1)
One of the strings has a length > 32K (but I have seen other cases where it failed already when a string had more that 255 chars)
The array size is larger than 64K (however, in Excel 2016 this will not cause a runtime error but a crippled array with less size
So, bet bet is to do the transform by hand which is rather easy. You should, by the way, use a Worksheet-variable for the sheets you add - never rely on Activesheet. The following code will create the new sheet only if it doesn't exist (else it will clear it's content so you can run the code several times
Set newWs = Nothing
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(wsName)
On Error GoTo 0
If newWs Is Nothing Then
' Sheet doesn't exist, create a new one and name it
Set newWs = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
newWs.Name = ws1.Cells(URL.row, 2).Value & "x" & ws1.Cells(6, 7).Value
Else
' Sheet already there, clear its content
newWs.UsedRange.ClearContents
End If
(..Load HTML and split..)
' Do your own transpose into a 2nd array and dump that into sheet
Dim brr
ReDim brr(LBound(arr) To UBound(arr), 1 To 1) ' Make it 2-dimensional
Dim i As Long
For i = LBound(arr) To UBound(arr)
brr(i, 1) = arr(i)
Next i
Range("A1").Resize(UBound(arr) + 1, 1).Value = brr

Changing the data-range of an existing PowerPoint-Chart using vba

I'm trying to do the following using vba:
I automatically gather data in Excel and want to paste it in an existing PowerPoint-Chart.
It is working fine, that's the way i do it (the paste-to-powerpoint-part):
Dim myChart As PowerPoint.Chart
Dim myChart As PowerPoint.Chart
Dim myData As PowerPoint.ChartData
Dim myWkb As Excel.Workbook
Dim myWks As Excel.Worksheet
Dim wbcd As Workbook
For chnmb = 1 To 1000
On Error Resume Next
Set myChart = ppSlide.Shapes(chnmb).Chart
'test_name = myChart.Name
If myChart.Name = "" Then Else Exit For
Next
I am doing this above (surely not the perfect way) because I don't know the Chart-Name (it is supposed to work for different Charts in different ppt-Files). After that:
Set myData = myChart.ChartData
Set myWkb = myData.Workbook
Set myWks = myWkb.Worksheets(1)
dat_area = "A1:" & Cells(1 + rowct, 1 + colct).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myWks.ListObjects(1).Resize myWks.Range(dat_area)
That is the part not working.
I manage to fill data into the Chart using:
myWks.Cells(j, i).Value = Workbooks("ppt-tool.xlsm").Sheets("Acc_Data").Cells(Row + j, 1 + i).Value
(via for-next; I don't want to paste the data but fill in every field) and to later edit the Chart, but it won´t change the data-area (with the blue border around it) of the ppt-Chart.
Strangely, if I create a new Chart using
Set myChart = ppSlide.Shapes.AddChart2(297, xlBarStacked100).Chart
I manage to resize the data area (with the same resize-code), but it's not working with existing Charts. Incidentally, I don't want to link the ppt-Chart to Excel (because the Excel-Tool is used over and over again with no data saved and the ppt-Charts may have to be edited later again).

Excel VBA To Process and Forward Emails Causing "Out of memory" Error

I hope someone can help- I'm hitting the dreaded "Out of memory or system resources" error with some code running in Excel and working with Outlook; from which the error originates.
Short description is it runs through a list of emails looking in the body/subject for a reference. If it finds it, it forwards the email item with the reference in the subject. MWE below; I'm not very experienced handling Outlook objects but I've spent nearly two hours trying different things with no luck. I can't use the GetTable() function since it doesn't include Body text data as far as I know (working off this), unless you can somehow add columns to include the body text?
If I run it in a freshly-opened Outlook session with only a dozen items it isn't a problem but I need it to work on hundreds of emails in one pop. Banging my head against a wall here. Thanks so much in advance!
Private Sub processMWE(ByVal oParent As Outlook.MAPIFolder)
Dim thisMail As Outlook.MailItem
Dim myItems As Outlook.Items
Dim emailindex As Integer
Dim folderpath As String
Dim refandType As Variant
Dim fwdItem
Set myItems = oParent.Items
folderpath = oParent.folderpath
'Starting at row 2 on the current sheet
i = 2
With myItems
'Data output to columns in Excel
For emailindex = 1 To .Count
Set thisMail = .Item(emailindex)
'i takes row value
Cells(i, 1).Value = folderpath
Cells(i, 2).Value = thisMail.Subject + " " + thisMail.Body
Cells(i, 3).Value = thisMail.SenderEmailAddress
Cells(i, 4).Value = thisMail.ReceivedTime
Cells(i, 6).Value = thisMail.Categories
'Reference from body/subject and a match type (integer)
refandType = extractInfo(Cells(i, 2))
'This is the reference
Cells(i, 5).Value = refandType(0)
'And this is the match type.
Select Case refandType(1)
Case 1, 2
'do nothing
Case Else
'For these match types, fwd the message
Set fwdItem = thisMail.Forward
fwdItem.Recipients.Add "#########"
fwdItem.Subject = Cells(i, 5) & " - " & thisMail.Subject
fwdItem.Send
'Edit original message category label
thisMail.Categories = "Forwarded"
thisMail.Save
'Note in spreadsheet
Cells(i, 7).Value = "Forwarded"
End If
End Select
i = i + 1
Next
End With
End Sub
Edit: New development: not only is it always hanging on the same line of code (thisMail.Body) it's actually doing it for specific mail items?! If I give it a batch of one of these problem messages it hangs immediately. Could it be something to do with character encoding or message length? Something that means thisMail.Body won't work that triggers a resources error?
Reason of the problem:
You are creating items without releasing them from memory -with these lines-
For emailindex = 1 To .Count
Set thisMail = .Item(emailindex)
Solution
Release the objects once you are done with them
End Select
i = i + 1
Set thisMail = Nothing
Next
End With
Common language explanation
In this scenario, think about VBA as a waiter, you are telling it that you are going to give some dishes to serve to the customers, you are giving all of them to it, but you never tell it to release them to the table, at one point, it will not be able to handle any more dishes ("Out of memory")

Copy email to the clipboard with Outlook VBA

How do I copy an email to the clipboard and then paste it into excel with the tables intact?
I am using Outlook 2007 and I want to do the equivalent of
"Click on email > Select All > Copy > Switch to Excel > Select Cell > Paste".
I have the Excel Object Model pretty well figured out, but have no experience in Outlook other than the following code.
Dim mapi As NameSpace
Dim msg As Outlook.MailItem
Set mapi = Outlook.Application.GetNamespace("MAPI")
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
I must admit I use this in Outlook 2003, but please see if it works in 2007 as well:
you can use the MSForms.DataObject to exchange data with the clipboard. In Outlook VBA, create a reference to "Microsoft Forms 2.0 Object Library", and try this code (you can of course attach the Sub() to a button, etc.):
Sub Test()
Dim M As MailItem, Buf As MSForms.DataObject
Set M = ActiveExplorer().Selection.Item(1)
Set Buf = New MSForms.DataObject
Buf.SetText M.HTMLBody
Buf.PutInClipboard
End Sub
After that, switch to Excel and press Ctrl-V - there we go!
If you also want to find the currently running Excel Application and automate even this, let me know.
There's always a valid HTMLBody, even when the mail was sent in Plain Text or RTF, and Excel will display all text attributes conveyed within HTMLBody incl. columns, colors, fonts, hyperlinks, indents etc. However, embedded images are not copied.
This code demonstrates the essentials, but doesn't check if really a MailItem is selected. This would require more coding, if you want to make it work for calendar entries, contacts, etc. as well.
It's enough if you have selected the mail in the list view, you don't even need to open it.
I finally picked it up again and completely automated it. Here are the basics of what I did to automate it.
Dim appExcel As Excel.Application
Dim Buf As MSForms.DataObject
Dim Shape As Excel.Shape
Dim mitm As MailItem
Dim itm As Object
Dim rws As Excel.Worksheet
'code to open excel
Set appExcel = VBA.GetObject(, "Excel.Application")
'...
'code to loop through emails here
Set mitm = itm
body = Replace(mitm.HTMLBody, "http://example.com/images/logo.jpg", "")
Call Buf.SetText(body)
Call Buf.PutInClipboard
Call rws.Cells(i, 1).PasteSpecial
For Each Shape In rws.Shapes
Shape.Delete 'this deletes the empty shapes
Next Shape
'next itm
I removed the logo urls to save time, and when you're dealing with 300 emails, that translates into at least ten minutes saved.
I got the code I needed from a TechRepublic article, and then changed it to suit my needs. Many thanks to the accepted answerer of this question for the clipboard code.
Ok so I will have to make certain assumptions because there is information missing from your question.
Firstly you didn't say what mailformat the message is... HTML would be the easiest, the process will be different for RTF and not possible in plaintext
Since you are refering to tables I will assume they are HTML tables and the mail format is HTML.
Also it is not clear from your question if you want the table content pasted seperately (1 excel cell per table cell) and the rest of the emails bodytext pasted into 1 cell or several?
finally you haven't really said if you want the VBA running from Outlook or Excel (not that important but it affects which intrinsic objects are available.
Anyway code sample:
Outlook code to access the htmlbody prop
Dim mapi As Namespace
Set mapi = Application.Session
Dim msg As MailItem
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
Dim strHTML as String
strHTML = msg.HTMLBody
' There is no object model collection for html tables within the htmlbody (which is a string of html) you will need to parse the html and collect the tables before inserting into Excel.
After a while again, I found another way. MailItem.Body is plain text, and has a tab character between table cells. So I used that. Here is the gist of what I did:
Sub Import()
Dim itms As Outlook.Items
Dim itm As Object
Dim i As Long, j As Long
Dim body As String
Dim mitm As Outlook.MailItem
For Each itm In itms
Set mitm = itm
ParseReports (mitm.body) 'uses the global var k
Next itm
End Sub
Sub ParseReports(text As String)
Dim table(1 To 1000, 1 To 11) As String 'I'm not expecting to see a thousand rows!
Dim drow(1 To 11) As String
For Each Row In VBA.Split(text, vbCrLf)
j = 1
For Each Col In VBA.Split(Row, vbTab)
table(i, j) = Col
j = j + 1
Next Col
i = i + 1
Next Row
For i = 1 To l
For j = 1 To 11
drow(j) = table(i, j)
Next j
hws.Range(hws.Cells(k, 1), hws.Cells(k, 11)) = drow
k = k + 1
Next i
End Sub
Average: 77 emails processed per second. I do some minor processing and extracting.

Resources