Simple Mail Merge in PowerPoint using VBA

MailMerge

Let’s create a simple mail merge in PowerPoint using Visual Basic for Applications (VBA).
Things you will need:
1. A table called “Employee” in a SQL Server Express 2012 database called “DB”. For Excel instead use this link: https://pepitosolis.wordpress.com/2013/05/10/mail-merge-in-powerpoint-using-vba-excel-version/

CREATE TABLE Employees
(
	Id int NOT NULL,
	FirstName varchar(50) NULL,
	LastName varchar(50) NULL,
	FileName varchar(300) NULL
)
 

The photographs will be .PNG or .JPG files located in a folder, the full path, for instance: “c:\Photos\1.jpg”, will be stored on the column “FileName”.
2. Insert some records to this table.

INSERT DB.dbo.Employees VALUES(1,'John','Smith','C:\Photos\1.jpg')
INSERT DB.dbo.Employees VALUES(2,'Michael','Wilson','C:\Photos\2.jpg')
INSERT DB.dbo.Employees VALUES(3,'Ned','Bach','C:\Photos\3.jpg')
INSERT DB.dbo.Employees VALUES(4,'Adolf','Wright','C:\Photos\4.jpg')

3. Create the folder “C:\Photos” and copy 4 pictures files with extension .jpg and rename them to “1.jpg”, “2.jpg”, “3.jpg” and “4.jpg”. You can use the same file just copy it and rename it.
4. Open PowerPoint and press “ALT + F11” to open the IDE for VBA.
5. Add a reference: Tools\References… Check “Microsoft ActiveX Data Objects 2.8 Library”, OK.
6. Add a module and copy and paste the following code:

Public Sub DoMailMerge()
	On Error GoTo errHandler
	Dim x As Slide
	Dim sh As Shape
	Dim i As Long

	'Delete all slides
	RemoveSlides

	Dim Cn As New ADODB.Connection
	Dim Rs As New ADODB.Recordset
	Cn.Open "Provider=SQLNCLI11;Server=YOURCOMPUTERNAME\SQLEXPRESS;Database=DB;Trusted_Connection=yes;"
	Rs.Open "SELECT Id, FirstName, LastName, FileName FROM DB.dbo.Employees", Cn, adOpenStatic, adLockReadOnly

	If Rs.EOF = True Then
		MsgBox "No Results"
		Exit Sub
	End If

	'Add slides needed.
	Dim NumSlides As Long
 	'We are going to use 3 records by slide, that's why we use 3 in the following code.
 	NumSlides = Int(Rs.RecordCount / 3)
 	'Add 1 if remainder of division greater than zero
 	If Rs.RecordCount Mod 3 > 0 Then
 		NumSlides = NumSlides + 1
 	End If
	Dim num As Long
	For num = 1 To NumSlides
		AddSlides
 	Next num
	'As we created all the slides needed we just navigate through them
	For Each x In ActiveWindow.Presentation.Slides
		'iterate 3 records
		For i = 1 To 3
			If Rs.EOF = False Then
				'Add a Title
				Set sh = x.Shapes.AddTextbox(msoTextOrientationHorizontal, 35, 30 + ((i - 1) * 150), 280, 14)
				sh.TextFrame.AutoSize = ppAutoSizeNone
				sh.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
	 			sh.TextFrame.TextRange.Font.Name = "Times New Roman"
				sh.TextFrame.TextRange.Font.Size = 10
				sh.TextFrame.TextRange.Font.Color.RGB = vbWhite
				sh.TextFrame.TextRange.Font.Bold = msoTrue
				sh.Fill.ForeColor.RGB = RGB(31, 73, 125)
				sh.TextFrame.VerticalAnchor = msoAnchorMiddle
				sh.Fill.Solid
				sh.TextFrame.TextRange.Text = "Employee " & Right("00000" & Trim(CStr(Rs!Id & "")), 5)
				'Add employee info from database
				Set sh = x.Shapes.AddTextbox(msoTextOrientationHorizontal, 36, 50 + ((i - 1) * 150), 145, 100) '.TextFrame.TextRange.Text = "hello"
				sh.TextFrame.TextRange.Font.Name = "Arial"
				sh.TextFrame.TextRange.Font.Size = 8
				sh.TextFrame.TextRange.Font.Bold = msoTrue
				sh.TextFrame.TextRange.Lines.ParagraphFormat.SpaceWithin = 1.5
				sh.TextFrame.TextRange.Text = "First Name : " & Trim(Rs!FirstName & "") & vbNewLine & _
								"Last Name: " & Trim(Rs!LastName & "") & vbNewLine & _
								"Id : " & Right("00000" & Trim(CStr(Rs!Id)), 5)
				'Add picture
				Set sh = x.Shapes.AddPicture(Rs!FileName & "", msoFalse, msoTrue, 190, 50 + ((i - 1) * 150))
				'Read the following record
				Rs.MoveNext
			Else
				Exit For
			End If
		Next i
	Next
errHandler:
	If Err.Number = -2147024809 Then 'File Not Found
		Resume Next
	End If
End Sub

Sub AddSlides()
	Dim Pre As Presentation
	Dim Sld As Slide
	Set Pre = ActivePresentation
	Set Sld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)
End Sub

Sub RemoveSlides()
	Dim Pre As Presentation
	Dim x As Long
	Set Pre = ActivePresentation
	For x = Pre.Slides.Count To 1 Step -1
		Pre.Slides(x).Delete
	Next x
End Sub

Notes:

  1. In the Connection string YOURCOMPUTERNAME has to be replaced by the name of your computer.
  2. In the image above you can see the employee’s picture repeated 4 times, you need to use 4 different pictures. I used the same picture 4 times shame on me for being lazy.
  3. When the job to do is too complex, too many shapes, background images, etc. Try to put all of the static content in the Slide Master. As a bonus you can’t mess with this content from a slide, it looks like a background template.

This was tested in PowerPoint version 2007 and 2010.

Advertisements
This entry was posted in PowerPoint and tagged , , , , , , , , , , , , . Bookmark the permalink.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s