├── README.md ├── XTemplateDoc.bas ├── XTemplateDoc.min.bas ├── XTemplateOut.bas ├── XTemplateOut.min.bas ├── XTemplatePpt.bas └── XTemplatePpt.min.bas /README.md: -------------------------------------------------------------------------------- 1 | # XTemplate 2 | 3 | ## Description 4 | 5 | [XTemplate](http://x-vba.com/xtemplate) is a tool for Microsoft Word, PowerPoint, and Outlook that is used to 6 | create templates that can easily pull information from Excel Workbooks so that 7 | you don't have to fetch this data manually. It provides a very simple template 8 | syntax, and makes working with recurring, standardized Documents, Presentations, 9 | and Emails much easier. 10 | 11 | ## Usage 12 | 13 | To use XTemplate, simply put templates throughout your Document, Presentations, 14 | and Emails, and then run the XTemplate macro. If the syntax is correct, and the 15 | Workbooks you want to fetch data from exist within the correct folder, the templates 16 | will be replaced with the value in the respective Workbook. The template syntax looks 17 | like this: 18 | 19 | {{ C:\Files\\\[MyWorkbook.xslx]MySheet!A1 }} 20 | 21 | In this case, when running the XTemplate Macro, this template will be replaced with 22 | the value in Range A1 within a Sheet named MySheet, within a Workbook named 23 | MyWorkbook.xlsx, which is founded within the folder C:\Files\ 24 | 25 | ## Download and Installation 26 | 27 | For more information about the template syntax, downloads, and installation, 28 | please see the official documentation. 29 | 30 | ## License 31 | 32 | The MIT License (MIT) 33 | 34 | Copyright © 2020 Anthony Mancini 35 | 36 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 37 | 38 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 39 | 40 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 41 | -------------------------------------------------------------------------------- /XTemplateDoc.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "XTemplateDoc" 2 | Option Explicit 3 | 4 | Private Function GetAllText() As String 5 | 6 | '@Description: This functions gathers all of the text in the various objects throughout the Document, including the Shapes, InlineShapes, Headers, Footers, and SmartArt 7 | '@Author: Anthony Mancini 8 | '@License: MIT 9 | '@Version: 1.0.0 10 | '@Note: This function will differ for each Office program 11 | '@Returns: Returns a large string containing all of the text throughout the Document 12 | 13 | Dim individualShape As Shape 14 | Dim individualInlineShape As InlineShape 15 | Dim individualSmartArtNode As SmartArtNode 16 | Dim individualSection As Section 17 | Dim individualHeaderFooter As HeaderFooter 18 | Dim allStrings As String 19 | 20 | ' Document content 21 | allStrings = ActiveDocument.Content.Text 22 | 23 | ' Text in shapes 24 | For Each individualShape In ActiveDocument.Shapes 25 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 26 | Next 27 | 28 | ' Text in inline shapes 29 | For Each individualInlineShape In ActiveDocument.InlineShapes 30 | allStrings = allStrings + individualInlineShape.Range.Text 31 | Next 32 | 33 | ' Text in smart art in shapes 34 | For Each individualShape In ActiveDocument.Shapes 35 | If individualShape.HasSmartArt Then 36 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 37 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 38 | Next 39 | End If 40 | Next 41 | 42 | ' Text in smart art in inline shapes 43 | For Each individualInlineShape In ActiveDocument.InlineShapes 44 | If individualInlineShape.HasSmartArt Then 45 | For Each individualSmartArtNode In individualInlineShape.SmartArt.AllNodes 46 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 47 | Next 48 | End If 49 | Next 50 | 51 | 52 | ' Sections like header and footer 53 | For Each individualSection In ActiveDocument.Sections 54 | For Each individualHeaderFooter In individualSection.Headers 55 | allStrings = allStrings + individualHeaderFooter.Range.Text 56 | Next 57 | 58 | For Each individualHeaderFooter In individualSection.Footers 59 | allStrings = allStrings + individualHeaderFooter.Range.Text 60 | Next 61 | Next 62 | 63 | ' Charts for shapes 64 | For Each individualShape In ActiveDocument.Shapes 65 | If individualShape.HasChart Then 66 | If individualShape.Chart.HasTitle Then 67 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 68 | End If 69 | End If 70 | Next 71 | 72 | ' Charts for inline shapes 73 | For Each individualInlineShape In ActiveDocument.InlineShapes 74 | If individualInlineShape.HasChart Then 75 | If individualInlineShape.Chart.HasTitle Then 76 | allStrings = allStrings + individualInlineShape.Chart.ChartTitle.Text 77 | End If 78 | End If 79 | Next 80 | 81 | GetAllText = allStrings 82 | 83 | End Function 84 | 85 | 86 | Private Function ParseOutTemplates( _ 87 | ByVal allStrings As String) _ 88 | As Variant 89 | 90 | '@Description: This functions uses a Regex to parse out all the templates from the string provided. It also throws a few errors if it finds a poorly formatted template. 91 | '@Author: Anthony Mancini 92 | '@License: MIT 93 | '@Version: 1.0.0 94 | '@Note: This function will differ for each Office Program, as some don't support Application.PathSeperator 95 | '@Param: allStrings is a string that will be regexed to find templates 96 | '@Returns: Returns a Dictionary in the following format: {OrigionalTemplate : FormattedTemplate}. The FormattedTemplate removes the curly braces and whitespace. 97 | 98 | ' Regexing out the templates 99 | Dim Regex As Object 100 | Set Regex = CreateObject("VBScript.RegExp") 101 | 102 | With Regex 103 | .Global = True 104 | .IgnoreCase = True 105 | .MultiLine = True 106 | .Pattern = "\{\{.*?\}\}" 107 | End With 108 | 109 | Dim individualMatch As Variant 110 | Dim individualStringTemplate As String 111 | Dim regexMatches As Variant 112 | 113 | Set regexMatches = Regex.Execute(allStrings) 114 | 115 | ' Creating the dictionary that will be returned 116 | Dim templateDictionary As Object 117 | Set templateDictionary = CreateObject("Scripting.Dictionary") 118 | 119 | For Each individualMatch In regexMatches 120 | individualStringTemplate = individualMatch.Value 121 | individualStringTemplate = Mid(individualStringTemplate, 3, Len(individualStringTemplate) - 4) 122 | individualStringTemplate = Trim(individualStringTemplate) 123 | 124 | ' Checks if some of the templates are missing a curly brace, as if it 125 | ' finds 3 curly braces in a template it means one template is missing 126 | ' a brace 127 | If InStr(1, individualStringTemplate, "{") Or InStr(1, individualStringTemplate, "}") Then 128 | MsgBox "Error, missing curly brace '{' or '}' on one of the templates:" & vbCrLf & vbCrLf & individualMatch.Value, Title:="Template Syntax Error" 129 | Exit Function 130 | End If 131 | 132 | ' Check if the template includes a path by looking for the path string seperator. 133 | ' Else use the path of the ActiveDocument to look for the Workbook 134 | If InStr(1, individualStringTemplate, Application.PathSeparator) Then 135 | If Not templateDictionary.Exists(individualMatch.Value) Then 136 | templateDictionary.Add individualMatch.Value, individualStringTemplate 137 | End If 138 | Else 139 | If Not templateDictionary.Exists(individualMatch.Value) Then 140 | templateDictionary.Add individualMatch.Value, ActiveDocument.Path & Application.PathSeparator & individualStringTemplate 141 | End If 142 | End If 143 | Next 144 | 145 | Set ParseOutTemplates = templateDictionary 146 | 147 | End Function 148 | 149 | 150 | Private Function FetchExcelData( _ 151 | ByVal templateDictionary As Variant) _ 152 | As Variant 153 | 154 | '@Description: This functions fetches out the data from the templates from the respective Excel files 155 | '@Author: Anthony Mancini 156 | '@License: MIT 157 | '@Version: 1.0.0 158 | '@Note: This function will be the same for each Office program 159 | '@Param: templateDictionary is a dictionary in the format: {OrigionalTemplate : FormattedTemplate} 160 | '@Returns: Returns a Dictionary in the following format: {OrigionalTemplate : FetchedValue} 161 | 162 | Dim ExcelApplication As Object 163 | Set ExcelApplication = CreateObject("Excel.Application") 164 | 165 | Dim currentWorkbook As Variant 166 | 167 | ExcelApplication.Visible = False 168 | 169 | 170 | Dim workbookPathDictionary As Object 171 | Set workbookPathDictionary = CreateObject("Scripting.Dictionary") 172 | 173 | Dim fetchTemplate As Variant 174 | Dim fullRangeDetails As String 175 | Dim workbookPath As String 176 | Dim workbookName As String 177 | Dim sheetName As String 178 | Dim rangeAddress As String 179 | 180 | ' Creating a workbook template dictionary containing collections 181 | ' of templates. This is used so that no workbook is opened up 182 | ' more than once when performing the fetches. The dictionary format 183 | ' is {WorkbookPath : templateDictionary} 184 | For Each fetchTemplate In templateDictionary.Keys() 185 | fullRangeDetails = Right(templateDictionary(fetchTemplate), Len(templateDictionary(fetchTemplate)) - InStrRev(templateDictionary(fetchTemplate), Application.PathSeparator)) 186 | 187 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 188 | workbookName = Mid(workbookName, 2) 189 | workbookPath = Left(templateDictionary(fetchTemplate), InStrRev(templateDictionary(fetchTemplate), Application.PathSeparator)) & workbookName 190 | 191 | If Not workbookPathDictionary.Exists(workbookPath) Then 192 | workbookPathDictionary.Add workbookPath, New Collection 193 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 194 | Else 195 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 196 | End If 197 | Next 198 | 199 | ' Actually performing the Excel Workbook fetches and creating a 200 | ' template dictionary in the following format: 201 | ' {Template : FetchedValue} 202 | Dim workbookPathKey As Variant 203 | Dim modifiedTemplateDictionary As Object 204 | Set modifiedTemplateDictionary = CreateObject("Scripting.Dictionary") 205 | 206 | For Each workbookPathKey In workbookPathDictionary.Keys() 207 | For Each fetchTemplate In workbookPathDictionary(workbookPathKey) 208 | fullRangeDetails = Right(fetchTemplate, Len(fetchTemplate) - InStrRev(fetchTemplate, Application.PathSeparator)) 209 | 210 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 211 | workbookName = Mid(workbookName, 2) 212 | workbookPath = Left(fetchTemplate, InStrRev(fetchTemplate, Application.PathSeparator)) & workbookName 213 | 214 | sheetName = Mid(fullRangeDetails, InStrRev(fullRangeDetails, "]") + 1) 215 | sheetName = Left(sheetName, InStrRev(sheetName, "!") - 1) 216 | 217 | rangeAddress = Right(fullRangeDetails, Len(fullRangeDetails) - InStrRev(fullRangeDetails, "!")) 218 | rangeAddress = Replace(rangeAddress, "$", "") 219 | 220 | ' Perform the fetch 221 | If Not modifiedTemplateDictionary.Exists(fetchTemplate) Then 222 | Set currentWorkbook = ExcelApplication.Workbooks.Open(workbookPath) 223 | 224 | modifiedTemplateDictionary.Add fetchTemplate, currentWorkbook.Sheets(sheetName).Range(rangeAddress).Value 225 | 226 | currentWorkbook.Close False 227 | Set currentWorkbook = Nothing 228 | End If 229 | Next 230 | Next 231 | 232 | ' Replacing the other templates with the origional templates 233 | Dim templateKey As Variant 234 | 235 | For Each templateKey In templateDictionary.Keys() 236 | templateDictionary(templateKey) = modifiedTemplateDictionary(templateDictionary(templateKey)) 237 | Next 238 | 239 | Set ExcelApplication = Nothing 240 | 241 | Set FetchExcelData = templateDictionary 242 | 243 | End Function 244 | 245 | 246 | Private Sub ReplaceTemplatesWithValues( _ 247 | ByVal templateDictionary As Variant) 248 | 249 | '@Description: This subroutine replaces all the templates in the Document with their value 250 | '@Author: Anthony Mancini 251 | '@License: MIT 252 | '@Version: 1.0.0 253 | '@Note: This function will differ for each Office program 254 | '@Param: templateDictionary is a dictionary in the format: {OrigionalTemplate : FetchedValue} 255 | 256 | Dim individualShape As Shape 257 | Dim individualInlineShape As InlineShape 258 | Dim individualSmartArtNode As SmartArtNode 259 | Dim individualSection As Section 260 | Dim individualHeaderFooter As HeaderFooter 261 | 262 | Dim templateKey As Variant 263 | Dim modifiedTemplateKey As String 264 | 265 | For Each templateKey In templateDictionary.Keys() 266 | 267 | ' Text in Document content 268 | With ActiveDocument.Range.Find 269 | .Text = templateKey 270 | .Replacement.Text = templateDictionary(templateKey) 271 | .Execute Replace:=wdReplaceAll 272 | End With 273 | 274 | ' Text in shapes 275 | For Each individualShape In ActiveDocument.Shapes 276 | individualShape.TextFrame.TextRange.Text = Replace(individualShape.TextFrame.TextRange.Text, templateKey, templateDictionary(templateKey)) 277 | Next 278 | 279 | ' Text in inline shapes 280 | For Each individualInlineShape In ActiveDocument.InlineShapes 281 | With individualInlineShape.Range.Find 282 | .Text = templateKey 283 | .Replacement.Text = templateDictionary(templateKey) 284 | .Execute Replace:=wdReplaceAll 285 | End With 286 | Next 287 | 288 | ' Text in smart art in shapes 289 | For Each individualShape In ActiveDocument.Shapes 290 | If individualShape.HasSmartArt Then 291 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 292 | individualSmartArtNode.TextFrame2.TextRange.Text = Replace(individualSmartArtNode.TextFrame2.TextRange.Text, templateKey, templateDictionary(templateKey)) 293 | Next 294 | End If 295 | Next 296 | 297 | ' Text in smart art in inline shapes 298 | For Each individualInlineShape In ActiveDocument.InlineShapes 299 | If individualInlineShape.HasSmartArt Then 300 | For Each individualSmartArtNode In individualInlineShape.SmartArt.AllNodes 301 | individualSmartArtNode.TextFrame2.TextRange.Text = Replace(individualSmartArtNode.TextFrame2.TextRange.Text, templateKey, templateDictionary(templateKey)) 302 | Next 303 | End If 304 | Next 305 | 306 | ' Sections like header and footer 307 | For Each individualSection In ActiveDocument.Sections 308 | For Each individualHeaderFooter In individualSection.Headers 309 | With individualHeaderFooter.Range.Find 310 | .Text = templateKey 311 | .Replacement.Text = templateDictionary(templateKey) 312 | .Execute Replace:=wdReplaceAll 313 | End With 314 | Next 315 | 316 | For Each individualHeaderFooter In individualSection.Footers 317 | With individualHeaderFooter.Range.Find 318 | .Text = templateKey 319 | .Replacement.Text = templateDictionary(templateKey) 320 | .Execute Replace:=wdReplaceAll 321 | End With 322 | Next 323 | Next 324 | 325 | ' Charts for shapes 326 | For Each individualShape In ActiveDocument.Shapes 327 | If individualShape.HasChart Then 328 | If individualShape.Chart.HasTitle Then 329 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 330 | End If 331 | End If 332 | Next 333 | 334 | ' Charts for inline shapes 335 | For Each individualInlineShape In ActiveDocument.InlineShapes 336 | If individualInlineShape.HasChart Then 337 | If individualInlineShape.Chart.HasTitle Then 338 | individualInlineShape.Chart.ChartTitle.Text = Replace(individualInlineShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 339 | End If 340 | End If 341 | Next 342 | 343 | Next 344 | 345 | End Sub 346 | 347 | 348 | Public Sub XTemplate() 349 | 350 | '@Description: This subroutine performs all the steps to run XTemplate 351 | '@Author: Anthony Mancini 352 | '@License: MIT 353 | '@Version: 1.0.0 354 | '@Note: This function will be thes same for each Office program 355 | 356 | ' Getting all the strings 357 | Dim allStrings As String 358 | allStrings = GetAllText() 359 | 360 | ' Parsing out the templates 361 | Dim origionalTemplateDictionary As Variant 362 | Set origionalTemplateDictionary = ParseOutTemplates(allStrings) 363 | 364 | ' Fetching the data from Excel 365 | Dim templateDictionary As Variant 366 | Set templateDictionary = FetchExcelData(origionalTemplateDictionary) 367 | 368 | ' Replacing the templates with values 369 | ReplaceTemplatesWithValues templateDictionary 370 | 371 | End Sub 372 | -------------------------------------------------------------------------------- /XTemplateDoc.min.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "XTemplateDoc" 2 | Option Explicit 3 | Private Function GetAllText() As String 4 | Dim individualShape As Shape 5 | Dim individualInlineShape As InlineShape 6 | Dim individualSmartArtNode As SmartArtNode 7 | Dim individualSection As Section 8 | Dim individualHeaderFooter As HeaderFooter 9 | Dim allStrings$ 10 | allStrings = ActiveDocument.Content.Text 11 | For Each individualShape In ActiveDocument.Shapes 12 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 13 | Next 14 | For Each individualInlineShape In ActiveDocument.InlineShapes 15 | allStrings = allStrings + individualInlineShape.Range.Text 16 | Next 17 | For Each individualShape In ActiveDocument.Shapes 18 | If individualShape.HasSmartArt Then 19 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 20 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 21 | Next 22 | End If 23 | Next 24 | For Each individualInlineShape In ActiveDocument.InlineShapes 25 | If individualInlineShape.HasSmartArt Then 26 | For Each individualSmartArtNode In individualInlineShape.SmartArt.AllNodes 27 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 28 | Next 29 | End If 30 | Next 31 | For Each individualSection In ActiveDocument.Sections 32 | For Each individualHeaderFooter In individualSection.Headers 33 | allStrings = allStrings + individualHeaderFooter.Range.Text 34 | Next 35 | For Each individualHeaderFooter In individualSection.Footers 36 | allStrings = allStrings + individualHeaderFooter.Range.Text 37 | Next 38 | Next 39 | For Each individualShape In ActiveDocument.Shapes 40 | If individualShape.HasChart Then 41 | If individualShape.Chart.HasTitle Then 42 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 43 | End If 44 | End If 45 | Next 46 | For Each individualInlineShape In ActiveDocument.InlineShapes 47 | If individualInlineShape.HasChart Then 48 | If individualInlineShape.Chart.HasTitle Then 49 | allStrings = allStrings + individualInlineShape.Chart.ChartTitle.Text 50 | End If 51 | End If 52 | Next 53 | GetAllText = allStrings 54 | End Function 55 | Private Function ParseOutTemplates( ByVal allStrings$) 56 | Dim Regex As Object 57 | Set Regex = CreateObject("VBScript.RegExp") 58 | With Regex 59 | .Global = True 60 | .IgnoreCase = True 61 | .MultiLine = True 62 | .Pattern = "\{\{.*?\}\}" 63 | End With 64 | Dim individualMatch 65 | Dim individualStringTemplate$ 66 | Dim regexMatches 67 | Set regexMatches = Regex.Execute(allStrings) 68 | Dim templateDictionary As Object 69 | Set templateDictionary = CreateObject("Scripting.Dictionary") 70 | For Each individualMatch In regexMatches 71 | individualStringTemplate = individualMatch.Value 72 | individualStringTemplate = Mid(individualStringTemplate, 3, Len(individualStringTemplate) - 4) 73 | individualStringTemplate = Trim(individualStringTemplate) 74 | If InStr(1, individualStringTemplate, "{") Or InStr(1, individualStringTemplate, "}") Then 75 | MsgBox "Error, missing curly brace '{' or '}' on one of the templates:" & vbCrLf & vbCrLf & individualMatch.Value, Title:="Template Syntax Error" 76 | Exit Function 77 | End If 78 | If InStr(1, individualStringTemplate, Application.PathSeparator) Then 79 | If Not templateDictionary.Exists(individualMatch.Value) Then 80 | templateDictionary.Add individualMatch.Value, individualStringTemplate 81 | End If 82 | Else 83 | If Not templateDictionary.Exists(individualMatch.Value) Then 84 | templateDictionary.Add individualMatch.Value, ActiveDocument.Path & Application.PathSeparator & individualStringTemplate 85 | End If 86 | End If 87 | Next 88 | Set ParseOutTemplates = templateDictionary 89 | End Function 90 | Private Function FetchExcelData( ByVal templateDictionary) 91 | Dim ExcelApplication As Object 92 | Set ExcelApplication = CreateObject("Excel.Application") 93 | Dim currentWorkbook 94 | ExcelApplication.Visible = False 95 | Dim workbookPathDictionary As Object 96 | Set workbookPathDictionary = CreateObject("Scripting.Dictionary") 97 | Dim fetchTemplate 98 | Dim fullRangeDetails$ 99 | Dim workbookPath$ 100 | Dim workbookName$ 101 | Dim sheetName$ 102 | Dim rangeAddress$ 103 | For Each fetchTemplate In templateDictionary.Keys() 104 | fullRangeDetails = Right(templateDictionary(fetchTemplate), Len(templateDictionary(fetchTemplate)) - InStrRev(templateDictionary(fetchTemplate), Application.PathSeparator)) 105 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 106 | workbookName = Mid(workbookName, 2) 107 | workbookPath = Left(templateDictionary(fetchTemplate), InStrRev(templateDictionary(fetchTemplate), Application.PathSeparator)) & workbookName 108 | If Not workbookPathDictionary.Exists(workbookPath) Then 109 | workbookPathDictionary.Add workbookPath, New Collection 110 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 111 | Else 112 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 113 | End If 114 | Next 115 | Dim workbookPathKey 116 | Dim modifiedTemplateDictionary As Object 117 | Set modifiedTemplateDictionary = CreateObject("Scripting.Dictionary") 118 | For Each workbookPathKey In workbookPathDictionary.Keys() 119 | For Each fetchTemplate In workbookPathDictionary(workbookPathKey) 120 | fullRangeDetails = Right(fetchTemplate, Len(fetchTemplate) - InStrRev(fetchTemplate, Application.PathSeparator)) 121 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 122 | workbookName = Mid(workbookName, 2) 123 | workbookPath = Left(fetchTemplate, InStrRev(fetchTemplate, Application.PathSeparator)) & workbookName 124 | sheetName = Mid(fullRangeDetails, InStrRev(fullRangeDetails, "]") + 1) 125 | sheetName = Left(sheetName, InStrRev(sheetName, "!") - 1) 126 | rangeAddress = Right(fullRangeDetails, Len(fullRangeDetails) - InStrRev(fullRangeDetails, "!")) 127 | rangeAddress = Replace(rangeAddress, "$", "") 128 | If Not modifiedTemplateDictionary.Exists(fetchTemplate) Then 129 | Set currentWorkbook = ExcelApplication.Workbooks.Open(workbookPath) 130 | modifiedTemplateDictionary.Add fetchTemplate, currentWorkbook.Sheets(sheetName).Range(rangeAddress).Value 131 | currentWorkbook.Close False 132 | Set currentWorkbook = Nothing 133 | End If 134 | Next 135 | Next 136 | Dim templateKey 137 | For Each templateKey In templateDictionary.Keys() 138 | templateDictionary(templateKey) = modifiedTemplateDictionary(templateDictionary(templateKey)) 139 | Next 140 | Set ExcelApplication = Nothing 141 | Set FetchExcelData = templateDictionary 142 | End Function 143 | Private Sub ReplaceTemplatesWithValues( ByVal templateDictionary) 144 | Dim individualShape As Shape 145 | Dim individualInlineShape As InlineShape 146 | Dim individualSmartArtNode As SmartArtNode 147 | Dim individualSection As Section 148 | Dim individualHeaderFooter As HeaderFooter 149 | Dim templateKey 150 | Dim modifiedTemplateKey$ 151 | For Each templateKey In templateDictionary.Keys() 152 | With ActiveDocument.Range.Find 153 | .Text = templateKey 154 | .Replacement.Text = templateDictionary(templateKey) 155 | .Execute Replace:=wdReplaceAll 156 | End With 157 | For Each individualShape In ActiveDocument.Shapes 158 | individualShape.TextFrame.TextRange.Text = Replace(individualShape.TextFrame.TextRange.Text, templateKey, templateDictionary(templateKey)) 159 | Next 160 | For Each individualInlineShape In ActiveDocument.InlineShapes 161 | With individualInlineShape.Range.Find 162 | .Text = templateKey 163 | .Replacement.Text = templateDictionary(templateKey) 164 | .Execute Replace:=wdReplaceAll 165 | End With 166 | Next 167 | For Each individualShape In ActiveDocument.Shapes 168 | If individualShape.HasSmartArt Then 169 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 170 | individualSmartArtNode.TextFrame2.TextRange.Text = Replace(individualSmartArtNode.TextFrame2.TextRange.Text, templateKey, templateDictionary(templateKey)) 171 | Next 172 | End If 173 | Next 174 | For Each individualInlineShape In ActiveDocument.InlineShapes 175 | If individualInlineShape.HasSmartArt Then 176 | For Each individualSmartArtNode In individualInlineShape.SmartArt.AllNodes 177 | individualSmartArtNode.TextFrame2.TextRange.Text = Replace(individualSmartArtNode.TextFrame2.TextRange.Text, templateKey, templateDictionary(templateKey)) 178 | Next 179 | End If 180 | Next 181 | For Each individualSection In ActiveDocument.Sections 182 | For Each individualHeaderFooter In individualSection.Headers 183 | With individualHeaderFooter.Range.Find 184 | .Text = templateKey 185 | .Replacement.Text = templateDictionary(templateKey) 186 | .Execute Replace:=wdReplaceAll 187 | End With 188 | Next 189 | For Each individualHeaderFooter In individualSection.Footers 190 | With individualHeaderFooter.Range.Find 191 | .Text = templateKey 192 | .Replacement.Text = templateDictionary(templateKey) 193 | .Execute Replace:=wdReplaceAll 194 | End With 195 | Next 196 | Next 197 | For Each individualShape In ActiveDocument.Shapes 198 | If individualShape.HasChart Then 199 | If individualShape.Chart.HasTitle Then 200 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 201 | End If 202 | End If 203 | Next 204 | For Each individualInlineShape In ActiveDocument.InlineShapes 205 | If individualInlineShape.HasChart Then 206 | If individualInlineShape.Chart.HasTitle Then 207 | individualInlineShape.Chart.ChartTitle.Text = Replace(individualInlineShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 208 | End If 209 | End If 210 | Next 211 | Next 212 | End Sub 213 | Public Sub XTemplate() 214 | Dim allStrings$ 215 | allStrings = GetAllText() 216 | Dim origionalTemplateDictionary 217 | Set origionalTemplateDictionary = ParseOutTemplates(allStrings) 218 | Dim templateDictionary 219 | Set templateDictionary = FetchExcelData(origionalTemplateDictionary) 220 | ReplaceTemplatesWithValues templateDictionary 221 | End Sub -------------------------------------------------------------------------------- /XTemplateOut.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "XTemplateOut" 2 | Option Explicit 3 | 4 | Private Function GetAllText() As String 5 | 6 | '@Description: This functions gathers all of the text in the various objects throughout the Outlook Mail or Appointment, including the To, Subject CC, BCC, and HTMLBody for the Mail, and To, Subject, and Body for the Appointment 7 | '@Author: Anthony Mancini 8 | '@License: MIT 9 | '@Version: 1.0.0 10 | '@Note: This function will differ for each Office program 11 | '@Returns: Returns a large string containing all of the text throughout the Document 12 | 13 | Dim allStrings As String 14 | 15 | If TypeName(Application.ActiveInspector.CurrentItem) = "MailItem" Then 16 | 17 | Dim individualMailItem As MailItem 18 | 19 | Set individualMailItem = Application.ActiveInspector.CurrentItem 20 | 21 | allStrings = allStrings + individualMailItem.To 22 | allStrings = allStrings + individualMailItem.Subject 23 | allStrings = allStrings + individualMailItem.CC 24 | allStrings = allStrings + individualMailItem.BCC 25 | allStrings = allStrings + individualMailItem.HTMLBody 26 | 27 | ElseIf TypeName(Application.ActiveInspector.CurrentItem) = "AppointmentItem" Then 28 | 29 | Dim individualAppointmentItem As AppointmentItem 30 | 31 | Set individualAppointmentItem = Application.ActiveInspector.CurrentItem 32 | 33 | allStrings = allStrings + individualAppointmentItem.Subject 34 | allStrings = allStrings + individualAppointmentItem.Location 35 | allStrings = allStrings + individualAppointmentItem.Body 36 | 37 | End If 38 | 39 | GetAllText = allStrings 40 | 41 | End Function 42 | 43 | 44 | Private Function ParseOutTemplates( _ 45 | ByVal allStrings As String) _ 46 | As Variant 47 | 48 | '@Description: This functions uses a Regex to parse out all the templates from the string provided. It also throws a few errors if it finds a poorly formatted template. 49 | '@Author: Anthony Mancini 50 | '@License: MIT 51 | '@Version: 1.0.0 52 | '@Note: This function will differ since Outlook will require absolute paths 53 | '@Param: allStrings is a string that will be regexed to find templates 54 | '@Returns: Returns a Dictionary in the following format: {OrigionalTemplate : FormattedTemplate}. The FormattedTemplate removes the curly braces and whitespace. 55 | 56 | ' Regexing out the templates 57 | Dim Regex As Object 58 | Set Regex = CreateObject("VBScript.RegExp") 59 | 60 | With Regex 61 | .Global = True 62 | .IgnoreCase = True 63 | .MultiLine = True 64 | .Pattern = "\{\{.*?\}\}" 65 | End With 66 | 67 | Dim individualMatch As Variant 68 | Dim individualStringTemplate As String 69 | Dim regexMatches As Variant 70 | 71 | Set regexMatches = Regex.Execute(allStrings) 72 | 73 | ' Creating the dictionary that will be returned 74 | Dim templateDictionary As Object 75 | Set templateDictionary = CreateObject("Scripting.Dictionary") 76 | 77 | For Each individualMatch In regexMatches 78 | individualStringTemplate = individualMatch.Value 79 | individualStringTemplate = Mid(individualStringTemplate, 3, Len(individualStringTemplate) - 4) 80 | individualStringTemplate = Trim(individualStringTemplate) 81 | 82 | ' Checks if some of the templates are missing a curly brace, as if it 83 | ' finds 3 curly braces in a template it means one template is missing 84 | ' a brace 85 | If InStr(1, individualStringTemplate, "{") Or InStr(1, individualStringTemplate, "}") Then 86 | MsgBox "Error, missing curly brace '{' or '}' on one of the templates:" & vbCrLf & vbCrLf & individualMatch.Value, Title:="Template Syntax Error" 87 | Exit Function 88 | End If 89 | 90 | ' No check for full path necessary, as it will always be needed 91 | If Not templateDictionary.Exists(individualMatch.Value) Then 92 | templateDictionary.Add individualMatch.Value, individualStringTemplate 93 | End If 94 | Next 95 | 96 | Set ParseOutTemplates = templateDictionary 97 | 98 | End Function 99 | 100 | 101 | Private Function FetchExcelData( _ 102 | ByVal templateDictionary As Variant) _ 103 | As Variant 104 | 105 | '@Description: This functions fetches out the data from the templates from the respective Excel files 106 | '@Author: Anthony Mancini 107 | '@License: MIT 108 | '@Version: 1.0.0 109 | '@Note: This function will be the same for each Office program 110 | '@Param: templateDictionary is a dictionary in the format: {OrigionalTemplate : FormattedTemplate} 111 | '@Returns: Returns a Dictionary in the following format: {OrigionalTemplate : FetchedValue} 112 | 113 | Dim ExcelApplication As Object 114 | Set ExcelApplication = CreateObject("Excel.Application") 115 | 116 | Dim currentWorkbook As Variant 117 | 118 | ExcelApplication.Visible = False 119 | 120 | 121 | Dim workbookPathDictionary As Object 122 | Set workbookPathDictionary = CreateObject("Scripting.Dictionary") 123 | 124 | Dim fetchTemplate As Variant 125 | Dim fullRangeDetails As String 126 | Dim workbookPath As String 127 | Dim workbookName As String 128 | Dim sheetName As String 129 | Dim rangeAddress As String 130 | 131 | ' Creating a workbook template dictionary containing collections 132 | ' of templates. This is used so that no workbook is opened up 133 | ' more than once when performing the fetches. The dictionary format 134 | ' is {WorkbookPath : templateDictionary} 135 | For Each fetchTemplate In templateDictionary.Keys() 136 | fullRangeDetails = Right(templateDictionary(fetchTemplate), Len(templateDictionary(fetchTemplate)) - InStrRev(templateDictionary(fetchTemplate), "\")) 137 | 138 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 139 | workbookName = Mid(workbookName, 2) 140 | workbookPath = Left(templateDictionary(fetchTemplate), InStrRev(templateDictionary(fetchTemplate), "\")) & workbookName 141 | 142 | If Not workbookPathDictionary.Exists(workbookPath) Then 143 | workbookPathDictionary.Add workbookPath, New Collection 144 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 145 | Else 146 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 147 | End If 148 | Next 149 | 150 | ' Actually performing the Excel Workbook fetches and creating a 151 | ' template dictionary in the following format: 152 | ' {Template : FetchedValue} 153 | Dim workbookPathKey As Variant 154 | Dim modifiedTemplateDictionary As Object 155 | Set modifiedTemplateDictionary = CreateObject("Scripting.Dictionary") 156 | 157 | For Each workbookPathKey In workbookPathDictionary.Keys() 158 | For Each fetchTemplate In workbookPathDictionary(workbookPathKey) 159 | fullRangeDetails = Right(fetchTemplate, Len(fetchTemplate) - InStrRev(fetchTemplate, "\")) 160 | 161 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 162 | workbookName = Mid(workbookName, 2) 163 | workbookPath = Left(fetchTemplate, InStrRev(fetchTemplate, "\")) & workbookName 164 | 165 | sheetName = Mid(fullRangeDetails, InStrRev(fullRangeDetails, "]") + 1) 166 | sheetName = Left(sheetName, InStrRev(sheetName, "!") - 1) 167 | 168 | rangeAddress = Right(fullRangeDetails, Len(fullRangeDetails) - InStrRev(fullRangeDetails, "!")) 169 | rangeAddress = Replace(rangeAddress, "$", "") 170 | 171 | ' Perform the fetch 172 | If Not modifiedTemplateDictionary.Exists(fetchTemplate) Then 173 | Set currentWorkbook = ExcelApplication.Workbooks.Open(workbookPath) 174 | 175 | modifiedTemplateDictionary.Add fetchTemplate, currentWorkbook.Sheets(sheetName).Range(rangeAddress).Value 176 | 177 | currentWorkbook.Close False 178 | Set currentWorkbook = Nothing 179 | End If 180 | Next 181 | Next 182 | 183 | ' Replacing the other templates with the origional templates 184 | Dim templateKey As Variant 185 | 186 | For Each templateKey In templateDictionary.Keys() 187 | templateDictionary(templateKey) = modifiedTemplateDictionary(templateDictionary(templateKey)) 188 | Next 189 | 190 | Set ExcelApplication = Nothing 191 | 192 | Set FetchExcelData = templateDictionary 193 | 194 | End Function 195 | 196 | 197 | Private Sub ReplaceTemplatesWithValues( _ 198 | ByVal templateDictionary As Variant) 199 | 200 | '@Description: This subroutine replaces all the templates in the Outlook Mail or Appointment with their value 201 | '@Author: Anthony Mancini 202 | '@License: MIT 203 | '@Version: 1.0.0 204 | '@Note: This function will differ for each Office program 205 | '@Param: templateDictionary is a dictionary in the format: {OrigionalTemplate : FetchedValue} 206 | 207 | Dim templateKey As Variant 208 | 209 | If TypeName(Application.ActiveInspector.CurrentItem) = "MailItem" Then 210 | 211 | Dim individualMailItem As MailItem 212 | Set individualMailItem = Application.ActiveInspector.CurrentItem 213 | 214 | For Each templateKey In templateDictionary.Keys() 215 | individualMailItem.To = Replace(individualMailItem.To, templateKey, templateDictionary(templateKey)) 216 | individualMailItem.Subject = Replace(individualMailItem.Subject, templateKey, templateDictionary(templateKey)) 217 | individualMailItem.CC = Replace(individualMailItem.CC, templateKey, templateDictionary(templateKey)) 218 | individualMailItem.BCC = Replace(individualMailItem.BCC, templateKey, templateDictionary(templateKey)) 219 | individualMailItem.HTMLBody = Replace(individualMailItem.HTMLBody, templateKey, templateDictionary(templateKey)) 220 | Next 221 | 222 | ElseIf TypeName(Application.ActiveInspector.CurrentItem) = "AppointmentItem" Then 223 | 224 | Dim individualAppointmentItem As AppointmentItem 225 | Set individualAppointmentItem = Application.ActiveInspector.CurrentItem 226 | 227 | For Each templateKey In templateDictionary.Keys() 228 | individualAppointmentItem.Subject = Replace(individualAppointmentItem.Subject, templateKey, templateDictionary(templateKey)) 229 | individualAppointmentItem.Location = Replace(individualAppointmentItem.Location, templateKey, templateDictionary(templateKey)) 230 | individualAppointmentItem.Body = Replace(individualAppointmentItem.Body, templateKey, templateDictionary(templateKey)) 231 | Next 232 | 233 | End If 234 | 235 | End Sub 236 | 237 | 238 | Public Sub XTemplate() 239 | 240 | '@Description: This subroutine performs all the steps to run XTemplate 241 | '@Author: Anthony Mancini 242 | '@License: MIT 243 | '@Version: 1.0.0 244 | '@Note: This function will be thes same for each Office program 245 | 246 | ' Getting all the strings 247 | Dim allStrings As String 248 | allStrings = GetAllText() 249 | 250 | ' Parsing out the templates 251 | Dim origionalTemplateDictionary As Variant 252 | Set origionalTemplateDictionary = ParseOutTemplates(allStrings) 253 | 254 | ' Fetching the data from Excel 255 | Dim templateDictionary As Variant 256 | Set templateDictionary = FetchExcelData(origionalTemplateDictionary) 257 | 258 | ' Replacing the templates with values 259 | ReplaceTemplatesWithValues templateDictionary 260 | 261 | End Sub 262 | -------------------------------------------------------------------------------- /XTemplateOut.min.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "XTemplateOut" 2 | Option Explicit 3 | Private Function GetAllText() As String 4 | Dim allStrings$ 5 | If TypeName(Application.ActiveInspector.CurrentItem) = "MailItem" Then 6 | Dim individualMailItem As MailItem 7 | Set individualMailItem = Application.ActiveInspector.CurrentItem 8 | allStrings = allStrings + individualMailItem.To 9 | allStrings = allStrings + individualMailItem.Subject 10 | allStrings = allStrings + individualMailItem.CC 11 | allStrings = allStrings + individualMailItem.BCC 12 | allStrings = allStrings + individualMailItem.HTMLBody 13 | ElseIf TypeName(Application.ActiveInspector.CurrentItem) = "AppointmentItem" Then 14 | Dim individualAppointmentItem As AppointmentItem 15 | Set individualAppointmentItem = Application.ActiveInspector.CurrentItem 16 | allStrings = allStrings + individualAppointmentItem.Subject 17 | allStrings = allStrings + individualAppointmentItem.Location 18 | allStrings = allStrings + individualAppointmentItem.Body 19 | End If 20 | GetAllText = allStrings 21 | End Function 22 | Private Function ParseOutTemplates( ByVal allStrings$) 23 | Dim Regex As Object 24 | Set Regex = CreateObject("VBScript.RegExp") 25 | With Regex 26 | .Global = True 27 | .IgnoreCase = True 28 | .MultiLine = True 29 | .Pattern = "\{\{.*?\}\}" 30 | End With 31 | Dim individualMatch 32 | Dim individualStringTemplate$ 33 | Dim regexMatches 34 | Set regexMatches = Regex.Execute(allStrings) 35 | Dim templateDictionary As Object 36 | Set templateDictionary = CreateObject("Scripting.Dictionary") 37 | For Each individualMatch In regexMatches 38 | individualStringTemplate = individualMatch.Value 39 | individualStringTemplate = Mid(individualStringTemplate, 3, Len(individualStringTemplate) - 4) 40 | individualStringTemplate = Trim(individualStringTemplate) 41 | If InStr(1, individualStringTemplate, "{") Or InStr(1, individualStringTemplate, "}") Then 42 | MsgBox "Error, missing curly brace '{' or '}' on one of the templates:" & vbCrLf & vbCrLf & individualMatch.Value, Title:="Template Syntax Error" 43 | Exit Function 44 | End If 45 | If Not templateDictionary.Exists(individualMatch.Value) Then 46 | templateDictionary.Add individualMatch.Value, individualStringTemplate 47 | End If 48 | Next 49 | Set ParseOutTemplates = templateDictionary 50 | End Function 51 | Private Function FetchExcelData( ByVal templateDictionary) 52 | Dim ExcelApplication As Object 53 | Set ExcelApplication = CreateObject("Excel.Application") 54 | Dim currentWorkbook 55 | ExcelApplication.Visible = False 56 | Dim workbookPathDictionary As Object 57 | Set workbookPathDictionary = CreateObject("Scripting.Dictionary") 58 | Dim fetchTemplate 59 | Dim fullRangeDetails$ 60 | Dim workbookPath$ 61 | Dim workbookName$ 62 | Dim sheetName$ 63 | Dim rangeAddress$ 64 | For Each fetchTemplate In templateDictionary.Keys() 65 | fullRangeDetails = Right(templateDictionary(fetchTemplate), Len(templateDictionary(fetchTemplate)) - InStrRev(templateDictionary(fetchTemplate), "\")) 66 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 67 | workbookName = Mid(workbookName, 2) 68 | workbookPath = Left(templateDictionary(fetchTemplate), InStrRev(templateDictionary(fetchTemplate), "\")) & workbookName 69 | If Not workbookPathDictionary.Exists(workbookPath) Then 70 | workbookPathDictionary.Add workbookPath, New Collection 71 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 72 | Else 73 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 74 | End If 75 | Next 76 | Dim workbookPathKey 77 | Dim modifiedTemplateDictionary As Object 78 | Set modifiedTemplateDictionary = CreateObject("Scripting.Dictionary") 79 | For Each workbookPathKey In workbookPathDictionary.Keys() 80 | For Each fetchTemplate In workbookPathDictionary(workbookPathKey) 81 | fullRangeDetails = Right(fetchTemplate, Len(fetchTemplate) - InStrRev(fetchTemplate, "\")) 82 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 83 | workbookName = Mid(workbookName, 2) 84 | workbookPath = Left(fetchTemplate, InStrRev(fetchTemplate, "\")) & workbookName 85 | sheetName = Mid(fullRangeDetails, InStrRev(fullRangeDetails, "]") + 1) 86 | sheetName = Left(sheetName, InStrRev(sheetName, "!") - 1) 87 | rangeAddress = Right(fullRangeDetails, Len(fullRangeDetails) - InStrRev(fullRangeDetails, "!")) 88 | rangeAddress = Replace(rangeAddress, "$", "") 89 | If Not modifiedTemplateDictionary.Exists(fetchTemplate) Then 90 | Set currentWorkbook = ExcelApplication.Workbooks.Open(workbookPath) 91 | modifiedTemplateDictionary.Add fetchTemplate, currentWorkbook.Sheets(sheetName).Range(rangeAddress).Value 92 | currentWorkbook.Close False 93 | Set currentWorkbook = Nothing 94 | End If 95 | Next 96 | Next 97 | Dim templateKey 98 | For Each templateKey In templateDictionary.Keys() 99 | templateDictionary(templateKey) = modifiedTemplateDictionary(templateDictionary(templateKey)) 100 | Next 101 | Set ExcelApplication = Nothing 102 | Set FetchExcelData = templateDictionary 103 | End Function 104 | Private Sub ReplaceTemplatesWithValues( ByVal templateDictionary) 105 | Dim templateKey 106 | If TypeName(Application.ActiveInspector.CurrentItem) = "MailItem" Then 107 | Dim individualMailItem As MailItem 108 | Set individualMailItem = Application.ActiveInspector.CurrentItem 109 | For Each templateKey In templateDictionary.Keys() 110 | individualMailItem.To = Replace(individualMailItem.To, templateKey, templateDictionary(templateKey)) 111 | individualMailItem.Subject = Replace(individualMailItem.Subject, templateKey, templateDictionary(templateKey)) 112 | individualMailItem.CC = Replace(individualMailItem.CC, templateKey, templateDictionary(templateKey)) 113 | individualMailItem.BCC = Replace(individualMailItem.BCC, templateKey, templateDictionary(templateKey)) 114 | individualMailItem.HTMLBody = Replace(individualMailItem.HTMLBody, templateKey, templateDictionary(templateKey)) 115 | Next 116 | ElseIf TypeName(Application.ActiveInspector.CurrentItem) = "AppointmentItem" Then 117 | Dim individualAppointmentItem As AppointmentItem 118 | Set individualAppointmentItem = Application.ActiveInspector.CurrentItem 119 | For Each templateKey In templateDictionary.Keys() 120 | individualAppointmentItem.Subject = Replace(individualAppointmentItem.Subject, templateKey, templateDictionary(templateKey)) 121 | individualAppointmentItem.Location = Replace(individualAppointmentItem.Location, templateKey, templateDictionary(templateKey)) 122 | individualAppointmentItem.Body = Replace(individualAppointmentItem.Body, templateKey, templateDictionary(templateKey)) 123 | Next 124 | End If 125 | End Sub 126 | Public Sub XTemplate() 127 | Dim allStrings$ 128 | allStrings = GetAllText() 129 | Dim origionalTemplateDictionary 130 | Set origionalTemplateDictionary = ParseOutTemplates(allStrings) 131 | Dim templateDictionary 132 | Set templateDictionary = FetchExcelData(origionalTemplateDictionary) 133 | ReplaceTemplatesWithValues templateDictionary 134 | End Sub -------------------------------------------------------------------------------- /XTemplatePpt.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "XTemplatePpt" 2 | Option Explicit 3 | 4 | Private Function GetAllText() As String 5 | 6 | '@Description: This functions gathers all of the text in the various objects throughout the Presentation, including the Shapes, Tables, Headers, Footers, SmartArt, Charts, and the Slide Master 7 | '@Author: Anthony Mancini 8 | '@License: MIT 9 | '@Version: 1.0.0 10 | '@Note: This function will differ for each Office program 11 | '@Returns: Returns a large string containing all of the text throughout the Document 12 | 13 | Dim individualSlide As Slide 14 | Dim individualShape As Shape 15 | Dim individualSmartArtNode As SmartArtNode 16 | Dim individualRow As Row 17 | Dim individualCell As Cell 18 | Dim individualDesign As Design 19 | Dim individualCustomLayout As CustomLayout 20 | Dim allStrings As String 21 | 22 | ' Presentation Slides 23 | For Each individualSlide In ActivePresentation.Slides 24 | 25 | For Each individualShape In individualSlide.Shapes 26 | 27 | ' Text in shapes 28 | On Error Resume Next 29 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 30 | On Error GoTo 0 31 | 32 | ' Text in smart art in shapes 33 | If individualShape.HasSmartArt Then 34 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 35 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 36 | Next 37 | End If 38 | 39 | ' Charts titles 40 | If individualShape.HasChart Then 41 | If individualShape.Chart.HasTitle Then 42 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 43 | End If 44 | End If 45 | 46 | ' Tables 47 | On Error Resume Next 48 | For Each individualRow In individualShape.Table.Rows 49 | For Each individualCell In individualRow.Cells 50 | allStrings = allStrings + individualCell.Shape.TextFrame.TextRange.Text 51 | Next 52 | Next 53 | On Error GoTo 0 54 | 55 | Next 56 | 57 | ' Header and Footer text if they exist 58 | On Error Resume Next 59 | allStrings = allStrings + individualSlide.HeadersFooters.Header.Text 60 | On Error GoTo 0 61 | 62 | On Error Resume Next 63 | allStrings = allStrings + individualSlide.HeadersFooters.Footer.Text 64 | On Error GoTo 0 65 | 66 | Next 67 | 68 | ' Presentation Slide Master 69 | For Each individualDesign In ActivePresentation.Designs 70 | 71 | For Each individualShape In individualDesign.SlideMaster.Shapes 72 | 73 | ' Text in shapes 74 | On Error Resume Next 75 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 76 | On Error GoTo 0 77 | 78 | ' Text in smart art in shapes 79 | If individualShape.HasSmartArt Then 80 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 81 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 82 | Next 83 | End If 84 | 85 | ' Charts titles 86 | If individualShape.HasChart Then 87 | If individualShape.Chart.HasTitle Then 88 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 89 | End If 90 | End If 91 | 92 | ' Tables 93 | On Error Resume Next 94 | For Each individualRow In individualShape.Table.Rows 95 | For Each individualCell In individualRow.Cells 96 | allStrings = allStrings + individualCell.Shape.TextFrame.TextRange.Text 97 | Next 98 | Next 99 | On Error GoTo 0 100 | 101 | Next 102 | 103 | ' Custom Layouts are for Layouts within a Slide in the SlideMaster 104 | For Each individualCustomLayout In individualDesign.SlideMaster.CustomLayouts 105 | 106 | For Each individualShape In individualCustomLayout.Shapes 107 | 108 | ' Text in shapes 109 | On Error Resume Next 110 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 111 | On Error GoTo 0 112 | 113 | ' Text in smart art in shapes 114 | If individualShape.HasSmartArt Then 115 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 116 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 117 | Next 118 | End If 119 | 120 | ' Charts titles 121 | If individualShape.HasChart Then 122 | If individualShape.Chart.HasTitle Then 123 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 124 | End If 125 | End If 126 | 127 | ' Tables 128 | On Error Resume Next 129 | For Each individualRow In individualShape.Table.Rows 130 | For Each individualCell In individualRow.Cells 131 | allStrings = allStrings + individualCell.Shape.TextFrame.TextRange.Text 132 | Next 133 | Next 134 | On Error GoTo 0 135 | 136 | Next 137 | 138 | Next 139 | 140 | Next 141 | 142 | GetAllText = allStrings 143 | 144 | End Function 145 | 146 | 147 | Private Function ParseOutTemplates( _ 148 | ByVal allStrings As String) _ 149 | As Variant 150 | 151 | '@Description: This functions uses a Regex to parse out all the templates from the string provided. It also throws a few errors if it finds a poorly formatted template. 152 | '@Author: Anthony Mancini 153 | '@License: MIT 154 | '@Version: 1.0.0 155 | '@Note: This function will be the same for each Office program. PowerPoint API doesn't include Application.PathSeparator. 156 | '@Param: allStrings is a string that will be regexed to find templates 157 | '@Returns: Returns a Dictionary in the following format: {OrigionalTemplate : FormattedTemplate}. The FormattedTemplate removes the curly braces and whitespace. 158 | 159 | ' Regexing out the templates 160 | Dim Regex As Object 161 | Set Regex = CreateObject("VBScript.RegExp") 162 | 163 | With Regex 164 | .Global = True 165 | .IgnoreCase = True 166 | .MultiLine = True 167 | .Pattern = "\{\{.*?\}\}" 168 | End With 169 | 170 | Dim individualMatch As Variant 171 | Dim individualStringTemplate As String 172 | Dim regexMatches As Variant 173 | 174 | Set regexMatches = Regex.Execute(allStrings) 175 | 176 | ' Creating the dictionary that will be returned 177 | Dim templateDictionary As Object 178 | Set templateDictionary = CreateObject("Scripting.Dictionary") 179 | 180 | For Each individualMatch In regexMatches 181 | individualStringTemplate = individualMatch.Value 182 | individualStringTemplate = Mid(individualStringTemplate, 3, Len(individualStringTemplate) - 4) 183 | individualStringTemplate = Trim(individualStringTemplate) 184 | 185 | ' Checks if some of the templates are missing a curly brace, as if it 186 | ' finds 3 curly braces in a template it means one template is missing 187 | ' a brace 188 | If InStr(1, individualStringTemplate, "{") Or InStr(1, individualStringTemplate, "}") Then 189 | MsgBox "Error, missing curly brace '{' or '}' on one of the templates:" & vbCrLf & vbCrLf & individualMatch.Value, Title:="Template Syntax Error" 190 | Exit Function 191 | End If 192 | 193 | ' Check if the template includes a path by looking for the path string seperator. 194 | ' Else use the path of the ActiveDocument to look for the Workbook 195 | If InStr(1, individualStringTemplate, "\") Then 196 | If Not templateDictionary.Exists(individualMatch.Value) Then 197 | templateDictionary.Add individualMatch.Value, individualStringTemplate 198 | End If 199 | Else 200 | If Not templateDictionary.Exists(individualMatch.Value) Then 201 | templateDictionary.Add individualMatch.Value, ActivePresentation.Path & "\" & individualStringTemplate 202 | End If 203 | End If 204 | Next 205 | 206 | Set ParseOutTemplates = templateDictionary 207 | 208 | End Function 209 | 210 | 211 | Private Function FetchExcelData( _ 212 | ByVal templateDictionary As Variant) _ 213 | As Variant 214 | 215 | '@Description: This functions fetches out the data from the templates from the respective Excel files 216 | '@Author: Anthony Mancini 217 | '@License: MIT 218 | '@Version: 1.0.0 219 | '@Note: This function will be the same for each Office program 220 | '@Param: templateDictionary is a dictionary in the format: {OrigionalTemplate : FormattedTemplate} 221 | '@Returns: Returns a Dictionary in the following format: {OrigionalTemplate : FetchedValue} 222 | 223 | Dim ExcelApplication As Object 224 | Set ExcelApplication = CreateObject("Excel.Application") 225 | 226 | Dim currentWorkbook As Variant 227 | 228 | ExcelApplication.Visible = False 229 | 230 | 231 | Dim workbookPathDictionary As Object 232 | Set workbookPathDictionary = CreateObject("Scripting.Dictionary") 233 | 234 | Dim fetchTemplate As Variant 235 | Dim fullRangeDetails As String 236 | Dim workbookPath As String 237 | Dim workbookName As String 238 | Dim sheetName As String 239 | Dim rangeAddress As String 240 | 241 | ' Creating a workbook template dictionary containing collections 242 | ' of templates. This is used so that no workbook is opened up 243 | ' more than once when performing the fetches. The dictionary format 244 | ' is {WorkbookPath : templateDictionary} 245 | For Each fetchTemplate In templateDictionary.Keys() 246 | fullRangeDetails = Right(templateDictionary(fetchTemplate), Len(templateDictionary(fetchTemplate)) - InStrRev(templateDictionary(fetchTemplate), "\")) 247 | 248 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 249 | workbookName = Mid(workbookName, 2) 250 | workbookPath = Left(templateDictionary(fetchTemplate), InStrRev(templateDictionary(fetchTemplate), "\")) & workbookName 251 | 252 | If Not workbookPathDictionary.Exists(workbookPath) Then 253 | workbookPathDictionary.Add workbookPath, New Collection 254 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 255 | Else 256 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 257 | End If 258 | Next 259 | 260 | ' Actually performing the Excel Workbook fetches and creating a 261 | ' template dictionary in the following format: 262 | ' {Template : FetchedValue} 263 | Dim workbookPathKey As Variant 264 | Dim modifiedTemplateDictionary As Object 265 | Set modifiedTemplateDictionary = CreateObject("Scripting.Dictionary") 266 | 267 | For Each workbookPathKey In workbookPathDictionary.Keys() 268 | For Each fetchTemplate In workbookPathDictionary(workbookPathKey) 269 | fullRangeDetails = Right(fetchTemplate, Len(fetchTemplate) - InStrRev(fetchTemplate, "\")) 270 | 271 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 272 | workbookName = Mid(workbookName, 2) 273 | workbookPath = Left(fetchTemplate, InStrRev(fetchTemplate, "\")) & workbookName 274 | 275 | sheetName = Mid(fullRangeDetails, InStrRev(fullRangeDetails, "]") + 1) 276 | sheetName = Left(sheetName, InStrRev(sheetName, "!") - 1) 277 | 278 | rangeAddress = Right(fullRangeDetails, Len(fullRangeDetails) - InStrRev(fullRangeDetails, "!")) 279 | rangeAddress = Replace(rangeAddress, "$", "") 280 | 281 | ' Perform the fetch 282 | If Not modifiedTemplateDictionary.Exists(fetchTemplate) Then 283 | Set currentWorkbook = ExcelApplication.Workbooks.Open(workbookPath) 284 | 285 | modifiedTemplateDictionary.Add fetchTemplate, currentWorkbook.Sheets(sheetName).Range(rangeAddress).Value 286 | 287 | currentWorkbook.Close False 288 | Set currentWorkbook = Nothing 289 | End If 290 | Next 291 | Next 292 | 293 | ' Replacing the other templates with the origional templates 294 | Dim templateKey As Variant 295 | 296 | For Each templateKey In templateDictionary.Keys() 297 | templateDictionary(templateKey) = modifiedTemplateDictionary(templateDictionary(templateKey)) 298 | Next 299 | 300 | Set ExcelApplication = Nothing 301 | 302 | Set FetchExcelData = templateDictionary 303 | 304 | End Function 305 | 306 | 307 | Private Sub ReplaceTemplatesWithValues( _ 308 | ByVal templateDictionary As Variant) 309 | 310 | '@Description: This subroutine replaces all the templates in the Presentation with their value 311 | '@Author: Anthony Mancini 312 | '@License: MIT 313 | '@Version: 1.0.0 314 | '@Note: This function will differ for each Office program 315 | '@Param: templateDictionary is a dictionary in the format: {OrigionalTemplate : FetchedValue} 316 | 317 | Dim individualSlide As Slide 318 | Dim individualShape As Shape 319 | Dim individualSmartArtNode As SmartArtNode 320 | Dim individualRow As Row 321 | Dim individualCell As Cell 322 | Dim individualDesign As Design 323 | Dim individualCustomLayout As CustomLayout 324 | 325 | Dim templateKey As Variant 326 | 327 | For Each templateKey In templateDictionary.Keys() 328 | 329 | ' Presentation Slides 330 | For Each individualSlide In ActivePresentation.Slides 331 | 332 | For Each individualShape In individualSlide.Shapes 333 | 334 | ' Text in shapes 335 | On Error Resume Next 336 | individualShape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 337 | On Error GoTo 0 338 | 339 | ' Text in smart art in shapes 340 | If individualShape.HasSmartArt Then 341 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 342 | individualSmartArtNode.TextFrame2.TextRange.Replace templateKey, templateDictionary(templateKey) 343 | Next 344 | End If 345 | 346 | ' Charts titles 347 | If individualShape.HasChart Then 348 | If individualShape.Chart.HasTitle Then 349 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 350 | End If 351 | End If 352 | 353 | ' Tables 354 | On Error Resume Next 355 | For Each individualRow In individualShape.Table.Rows 356 | For Each individualCell In individualRow.Cells 357 | individualCell.Shape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 358 | Next 359 | Next 360 | On Error GoTo 0 361 | 362 | Next 363 | 364 | ' Header and Footer text if they exist 365 | On Error Resume Next 366 | individualSlide.HeadersFooters.Header.Text = Replace(individualSlide.HeadersFooters.Header.Text, templateKey, templateDictionary(templateKey)) 367 | On Error GoTo 0 368 | 369 | On Error Resume Next 370 | individualSlide.HeadersFooters.Footer.Text = Replace(individualSlide.HeadersFooters.Footer.Text, templateKey, templateDictionary(templateKey)) 371 | On Error GoTo 0 372 | 373 | Next 374 | 375 | 376 | ' Presentation Slide Master 377 | For Each individualDesign In ActivePresentation.Designs 378 | 379 | For Each individualShape In individualDesign.SlideMaster.Shapes 380 | 381 | ' Text in shapes 382 | On Error Resume Next 383 | individualShape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 384 | On Error GoTo 0 385 | 386 | ' Text in smart art in shapes 387 | If individualShape.HasSmartArt Then 388 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 389 | individualSmartArtNode.TextFrame2.TextRange.Replace templateKey, templateDictionary(templateKey) 390 | Next 391 | End If 392 | 393 | ' Charts titles 394 | If individualShape.HasChart Then 395 | If individualShape.Chart.HasTitle Then 396 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 397 | End If 398 | End If 399 | 400 | ' Tables 401 | On Error Resume Next 402 | For Each individualRow In individualShape.Table.Rows 403 | For Each individualCell In individualRow.Cells 404 | individualCell.Shape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 405 | Next 406 | Next 407 | On Error GoTo 0 408 | 409 | Next 410 | 411 | 412 | ' Custom Layouts are for Layouts within a Slide in the SlideMaster 413 | For Each individualCustomLayout In individualDesign.SlideMaster.CustomLayouts 414 | 415 | For Each individualShape In individualCustomLayout.Shapes 416 | 417 | ' Text in shapes 418 | On Error Resume Next 419 | individualShape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 420 | On Error GoTo 0 421 | 422 | ' Text in smart art in shapes 423 | If individualShape.HasSmartArt Then 424 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 425 | individualSmartArtNode.TextFrame2.TextRange.Replace templateKey, templateDictionary(templateKey) 426 | Next 427 | End If 428 | 429 | ' Charts titles 430 | If individualShape.HasChart Then 431 | If individualShape.Chart.HasTitle Then 432 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 433 | End If 434 | End If 435 | 436 | ' Tables 437 | On Error Resume Next 438 | For Each individualRow In individualShape.Table.Rows 439 | For Each individualCell In individualRow.Cells 440 | individualCell.Shape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 441 | Next 442 | Next 443 | On Error GoTo 0 444 | 445 | Next 446 | 447 | Next 448 | 449 | Next 450 | 451 | Next 452 | 453 | End Sub 454 | 455 | 456 | Public Sub XTemplate() 457 | 458 | '@Description: This subroutine performs all the steps to run XTemplate 459 | '@Author: Anthony Mancini 460 | '@License: MIT 461 | '@Version: 1.0.0 462 | '@Note: This function will be thes same for each Office program 463 | 464 | ' Getting all the strings 465 | Dim allStrings As String 466 | allStrings = GetAllText() 467 | 468 | ' Parsing out the templates 469 | Dim origionalTemplateDictionary As Variant 470 | Set origionalTemplateDictionary = ParseOutTemplates(allStrings) 471 | 472 | ' Fetching the data from Excel 473 | Dim templateDictionary As Variant 474 | Set templateDictionary = FetchExcelData(origionalTemplateDictionary) 475 | 476 | ' Replacing the templates with values 477 | ReplaceTemplatesWithValues templateDictionary 478 | 479 | End Sub 480 | 481 | -------------------------------------------------------------------------------- /XTemplatePpt.min.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "XTemplatePpt" 2 | Option Explicit 3 | Private Function GetAllText() As String 4 | Dim individualSlide As Slide 5 | Dim individualShape As Shape 6 | Dim individualSmartArtNode As SmartArtNode 7 | Dim individualRow As Row 8 | Dim individualCell As Cell 9 | Dim individualDesign As Design 10 | Dim individualCustomLayout As CustomLayout 11 | Dim allStrings$ 12 | For Each individualSlide In ActivePresentation.Slides 13 | For Each individualShape In individualSlide.Shapes 14 | On Error Resume Next 15 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 16 | On Error GoTo 0 17 | If individualShape.HasSmartArt Then 18 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 19 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 20 | Next 21 | End If 22 | If individualShape.HasChart Then 23 | If individualShape.Chart.HasTitle Then 24 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 25 | End If 26 | End If 27 | On Error Resume Next 28 | For Each individualRow In individualShape.Table.Rows 29 | For Each individualCell In individualRow.Cells 30 | allStrings = allStrings + individualCell.Shape.TextFrame.TextRange.Text 31 | Next 32 | Next 33 | On Error GoTo 0 34 | Next 35 | On Error Resume Next 36 | allStrings = allStrings + individualSlide.HeadersFooters.Header.Text 37 | On Error GoTo 0 38 | On Error Resume Next 39 | allStrings = allStrings + individualSlide.HeadersFooters.Footer.Text 40 | On Error GoTo 0 41 | Next 42 | For Each individualDesign In ActivePresentation.Designs 43 | For Each individualShape In individualDesign.SlideMaster.Shapes 44 | On Error Resume Next 45 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 46 | On Error GoTo 0 47 | If individualShape.HasSmartArt Then 48 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 49 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 50 | Next 51 | End If 52 | If individualShape.HasChart Then 53 | If individualShape.Chart.HasTitle Then 54 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 55 | End If 56 | End If 57 | On Error Resume Next 58 | For Each individualRow In individualShape.Table.Rows 59 | For Each individualCell In individualRow.Cells 60 | allStrings = allStrings + individualCell.Shape.TextFrame.TextRange.Text 61 | Next 62 | Next 63 | On Error GoTo 0 64 | Next 65 | For Each individualCustomLayout In individualDesign.SlideMaster.CustomLayouts 66 | For Each individualShape In individualCustomLayout.Shapes 67 | On Error Resume Next 68 | allStrings = allStrings + individualShape.TextFrame.TextRange.Text 69 | On Error GoTo 0 70 | If individualShape.HasSmartArt Then 71 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 72 | allStrings = allStrings + individualSmartArtNode.TextFrame2.TextRange.Text 73 | Next 74 | End If 75 | If individualShape.HasChart Then 76 | If individualShape.Chart.HasTitle Then 77 | allStrings = allStrings + individualShape.Chart.ChartTitle.Text 78 | End If 79 | End If 80 | On Error Resume Next 81 | For Each individualRow In individualShape.Table.Rows 82 | For Each individualCell In individualRow.Cells 83 | allStrings = allStrings + individualCell.Shape.TextFrame.TextRange.Text 84 | Next 85 | Next 86 | On Error GoTo 0 87 | Next 88 | Next 89 | Next 90 | GetAllText = allStrings 91 | End Function 92 | Private Function ParseOutTemplates( ByVal allStrings$) 93 | Dim Regex As Object 94 | Set Regex = CreateObject("VBScript.RegExp") 95 | With Regex 96 | .Global = True 97 | .IgnoreCase = True 98 | .MultiLine = True 99 | .Pattern = "\{\{.*?\}\}" 100 | End With 101 | Dim individualMatch 102 | Dim individualStringTemplate$ 103 | Dim regexMatches 104 | Set regexMatches = Regex.Execute(allStrings) 105 | Dim templateDictionary As Object 106 | Set templateDictionary = CreateObject("Scripting.Dictionary") 107 | For Each individualMatch In regexMatches 108 | individualStringTemplate = individualMatch.Value 109 | individualStringTemplate = Mid(individualStringTemplate, 3, Len(individualStringTemplate) - 4) 110 | individualStringTemplate = Trim(individualStringTemplate) 111 | If InStr(1, individualStringTemplate, "{") Or InStr(1, individualStringTemplate, "}") Then 112 | MsgBox "Error, missing curly brace '{' or '}' on one of the templates:" & vbCrLf & vbCrLf & individualMatch.Value, Title:="Template Syntax Error" 113 | Exit Function 114 | End If 115 | If InStr(1, individualStringTemplate, "\") Then 116 | If Not templateDictionary.Exists(individualMatch.Value) Then 117 | templateDictionary.Add individualMatch.Value, individualStringTemplate 118 | End If 119 | Else 120 | If Not templateDictionary.Exists(individualMatch.Value) Then 121 | templateDictionary.Add individualMatch.Value, ActivePresentation.Path & "\" & individualStringTemplate 122 | End If 123 | End If 124 | Next 125 | Set ParseOutTemplates = templateDictionary 126 | End Function 127 | Private Function FetchExcelData( ByVal templateDictionary) 128 | Dim ExcelApplication As Object 129 | Set ExcelApplication = CreateObject("Excel.Application") 130 | Dim currentWorkbook 131 | ExcelApplication.Visible = False 132 | Dim workbookPathDictionary As Object 133 | Set workbookPathDictionary = CreateObject("Scripting.Dictionary") 134 | Dim fetchTemplate 135 | Dim fullRangeDetails$ 136 | Dim workbookPath$ 137 | Dim workbookName$ 138 | Dim sheetName$ 139 | Dim rangeAddress$ 140 | For Each fetchTemplate In templateDictionary.Keys() 141 | fullRangeDetails = Right(templateDictionary(fetchTemplate), Len(templateDictionary(fetchTemplate)) - InStrRev(templateDictionary(fetchTemplate), "\")) 142 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 143 | workbookName = Mid(workbookName, 2) 144 | workbookPath = Left(templateDictionary(fetchTemplate), InStrRev(templateDictionary(fetchTemplate), "\")) & workbookName 145 | If Not workbookPathDictionary.Exists(workbookPath) Then 146 | workbookPathDictionary.Add workbookPath, New Collection 147 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 148 | Else 149 | workbookPathDictionary.Item(workbookPath).Add templateDictionary(fetchTemplate) 150 | End If 151 | Next 152 | Dim workbookPathKey 153 | Dim modifiedTemplateDictionary As Object 154 | Set modifiedTemplateDictionary = CreateObject("Scripting.Dictionary") 155 | For Each workbookPathKey In workbookPathDictionary.Keys() 156 | For Each fetchTemplate In workbookPathDictionary(workbookPathKey) 157 | fullRangeDetails = Right(fetchTemplate, Len(fetchTemplate) - InStrRev(fetchTemplate, "\")) 158 | workbookName = Left(fullRangeDetails, InStrRev(fullRangeDetails, "]") - 1) 159 | workbookName = Mid(workbookName, 2) 160 | workbookPath = Left(fetchTemplate, InStrRev(fetchTemplate, "\")) & workbookName 161 | sheetName = Mid(fullRangeDetails, InStrRev(fullRangeDetails, "]") + 1) 162 | sheetName = Left(sheetName, InStrRev(sheetName, "!") - 1) 163 | rangeAddress = Right(fullRangeDetails, Len(fullRangeDetails) - InStrRev(fullRangeDetails, "!")) 164 | rangeAddress = Replace(rangeAddress, "$", "") 165 | If Not modifiedTemplateDictionary.Exists(fetchTemplate) Then 166 | Set currentWorkbook = ExcelApplication.Workbooks.Open(workbookPath) 167 | modifiedTemplateDictionary.Add fetchTemplate, currentWorkbook.Sheets(sheetName).Range(rangeAddress).Value 168 | currentWorkbook.Close False 169 | Set currentWorkbook = Nothing 170 | End If 171 | Next 172 | Next 173 | Dim templateKey 174 | For Each templateKey In templateDictionary.Keys() 175 | templateDictionary(templateKey) = modifiedTemplateDictionary(templateDictionary(templateKey)) 176 | Next 177 | Set ExcelApplication = Nothing 178 | Set FetchExcelData = templateDictionary 179 | End Function 180 | Private Sub ReplaceTemplatesWithValues( ByVal templateDictionary) 181 | Dim individualSlide As Slide 182 | Dim individualShape As Shape 183 | Dim individualSmartArtNode As SmartArtNode 184 | Dim individualRow As Row 185 | Dim individualCell As Cell 186 | Dim individualDesign As Design 187 | Dim individualCustomLayout As CustomLayout 188 | Dim templateKey 189 | For Each templateKey In templateDictionary.Keys() 190 | For Each individualSlide In ActivePresentation.Slides 191 | For Each individualShape In individualSlide.Shapes 192 | On Error Resume Next 193 | individualShape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 194 | On Error GoTo 0 195 | If individualShape.HasSmartArt Then 196 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 197 | individualSmartArtNode.TextFrame2.TextRange.Replace templateKey, templateDictionary(templateKey) 198 | Next 199 | End If 200 | If individualShape.HasChart Then 201 | If individualShape.Chart.HasTitle Then 202 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 203 | End If 204 | End If 205 | On Error Resume Next 206 | For Each individualRow In individualShape.Table.Rows 207 | For Each individualCell In individualRow.Cells 208 | individualCell.Shape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 209 | Next 210 | Next 211 | On Error GoTo 0 212 | Next 213 | On Error Resume Next 214 | individualSlide.HeadersFooters.Header.Text = Replace(individualSlide.HeadersFooters.Header.Text, templateKey, templateDictionary(templateKey)) 215 | On Error GoTo 0 216 | On Error Resume Next 217 | individualSlide.HeadersFooters.Footer.Text = Replace(individualSlide.HeadersFooters.Footer.Text, templateKey, templateDictionary(templateKey)) 218 | On Error GoTo 0 219 | Next 220 | For Each individualDesign In ActivePresentation.Designs 221 | For Each individualShape In individualDesign.SlideMaster.Shapes 222 | On Error Resume Next 223 | individualShape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 224 | On Error GoTo 0 225 | If individualShape.HasSmartArt Then 226 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 227 | individualSmartArtNode.TextFrame2.TextRange.Replace templateKey, templateDictionary(templateKey) 228 | Next 229 | End If 230 | If individualShape.HasChart Then 231 | If individualShape.Chart.HasTitle Then 232 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 233 | End If 234 | End If 235 | On Error Resume Next 236 | For Each individualRow In individualShape.Table.Rows 237 | For Each individualCell In individualRow.Cells 238 | individualCell.Shape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 239 | Next 240 | Next 241 | On Error GoTo 0 242 | Next 243 | For Each individualCustomLayout In individualDesign.SlideMaster.CustomLayouts 244 | For Each individualShape In individualCustomLayout.Shapes 245 | On Error Resume Next 246 | individualShape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 247 | On Error GoTo 0 248 | If individualShape.HasSmartArt Then 249 | For Each individualSmartArtNode In individualShape.SmartArt.AllNodes 250 | individualSmartArtNode.TextFrame2.TextRange.Replace templateKey, templateDictionary(templateKey) 251 | Next 252 | End If 253 | If individualShape.HasChart Then 254 | If individualShape.Chart.HasTitle Then 255 | individualShape.Chart.ChartTitle.Text = Replace(individualShape.Chart.ChartTitle.Text, templateKey, templateDictionary(templateKey)) 256 | End If 257 | End If 258 | On Error Resume Next 259 | For Each individualRow In individualShape.Table.Rows 260 | For Each individualCell In individualRow.Cells 261 | individualCell.Shape.TextFrame.TextRange.Replace templateKey, templateDictionary(templateKey) 262 | Next 263 | Next 264 | On Error GoTo 0 265 | Next 266 | Next 267 | Next 268 | Next 269 | End Sub 270 | Public Sub XTemplate() 271 | Dim allStrings$ 272 | allStrings = GetAllText() 273 | Dim origionalTemplateDictionary 274 | Set origionalTemplateDictionary = ParseOutTemplates(allStrings) 275 | Dim templateDictionary 276 | Set templateDictionary = FetchExcelData(origionalTemplateDictionary) 277 | ReplaceTemplatesWithValues templateDictionary 278 | End Sub --------------------------------------------------------------------------------