Inserting Text Box in Word Doc from excel

[danpre]

Dear Team,

Hope you are doing great.

I have 1 requirement where i need to prepare word doc letter and send to all finance manager through outlook as attachment.

I have written macro code for the same which is working fine but i have additional requirement in this code is where supplier Name and address should come in "Text Box" as shown below and not typed as normal which should come after To Finance Manager .

To Finance Manager,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<?xml:namespace prefix = v ns = "urn:schemas-microsoft-com:vml" /><v:shapetype id=_x0000_t202 path="m,l,21600r21600,l21600,xe" o:spt="202" coordsize="21600,21600"><v:stroke joinstyle="miter"></v:stroke><vath o:connecttype="rect" gradientshapeok="t"></vath></v:shapetype><v:shape style="Z-INDEX: 251659264; POSITION: absolute; MARGIN-TOP: 2.75pt; WIDTH: 256.5pt; HEIGHT: 116.25pt; VISIBILITY: visible; MARGIN-LEFT: -5.25pt; mso-wrap-style: square; mso-width-percent: 0; mso-height-percent: 0; mso-wrap-distance-left: 9pt; mso-wrap-distance-top: 0; mso-wrap-distance-right: 9pt; mso-wrap-distance-bottom: 0; mso-position-horizontal: absolute; mso-position-horizontal-relative: text; mso-position-vertical: absolute; mso-position-vertical-relative: text; mso-width-relative: margin; mso-height-relative: margin; v-text-anchor: top" id=Text_x0020_Box_x0020_2 stroked="f" o:gfxdata="UEsDBBQABgAIAAAAIQC75UiUBQEAAB4CAAATAAAAW0NvbnRlbnRfVHlwZXNdLnhtbKSRvU7DMBSFdyTewfKKEqcMCKEmHfgZgaE8wMW+SSwc27JvS/v23KTJgkoXFsu+P+c7Ol5vDoMTe0zZBl/LVVlJgV4HY31Xy4/tS3EvRSbwBlzwWMsjZrlprq/W22PELHjb51r2RPFBqax7HCCXIaLnThvSAMTP1KkI+gs6VLdVdad08ISeCho1ZLN+whZ2jsTzgcsnJwldluLxNDiyagkxOquB2Knae/OLUsyEkjenmdzbmG/YhlRnCWPnb8C898bRJGtQvEOiVxjYhtLOxs8AySiT4JuDystlVV4WPeM6tK3VaILeDZxIOSsuti/jidNGNZ3/J08yC1dNv9v8AAAA//8DAFBLAwQUAAYACAAAACEArTA/8cEAAAAyAQAACwAAAF9yZWxzLy5yZWxzhI/NCsIwEITvgu8Q9m7TehCRpr2I4FX0AdZk2wbbJGTj39ubi6AgeJtl2G9m6vYxjeJGka13CqqiBEFOe2Ndr+B03C3WIDihMzh6RwqexNA281l9oBFTfuLBBhaZ4ljBkFLYSMl6oAm58IFcdjofJ0z5jL0MqC/Yk1yW5UrGTwY0X0yxNwri3lQgjs+Qk/+zfddZTVuvrxO59CNCmoj3vCwjMfaUFOjRhrPHaN4Wv0VV5OYgm1p+LW1eAAAA//8DAFBLAwQUAAYACAAAACEATfc5ie8CAAAbCAAAHwAAAGNsaXBib2FyZC9kcmF3aW5ncy9kcmF3aW5nMS54bWzkVc1u2zAMvg/YOwi6t06TuEmDOkWatUWBLguS9jwwshwLkyVPUv76SnuE3fpko2SndbuhBbYdBsyHRJSojx8/0vTp2baQZM2NFVol9OiwRQlXTKdCLRN6d3t50KfEOlApSK14Qnfc0rPh+3enMFgaKHPBCCIoO4CE5s6VgyiyLOcF2ENdcoVnmTYFODTNMkoNbBC5kFG71TqOChCKDp+gPoADsjLiN6CkZl94Oga1BouQkg2aOzVHyf4cGQZqfWXKeTk1njmbrKeGiDShqJyCAiWiUX1Qu6EZvbi1fALYZqbw/jrLyDah/W6/c4xQOyzGUbsb9+MKjm8dYXjeace9OEYH5j26veNOr/Zg+afXIVh+8QYI0qzo4KJB0ZaeoFr/nHOn1dtnfesZnustaT/m7/2J2+ImUg11tuUN1skSpcc5qCUfGaM3OYfUeo9KKFS0ChRE28e0Hmux+ahTVBhWTge8vyTeY94wKI11V1wXxC8SajhzIRKsb6yrCO5dvChWS5FeCimDYZaLsTRkDTKhl+Gpc3rmJhXZJPQkbscBWWl/P/RMIRw3RIoC+6Dln0pKL9CFSoOLAyGrNZKWKrSW18bHd9t5qJSXPN35nQX+o25GYyrYM/ie4yLX5p6SDb69CbVfV2A4JfJaYQlOjrpddHPB6Ma9NhqmebJonoBiCJVQR0m1HDu0WnVSI6xRJmrJKh6ekbRu7naSh2QCW1/YAsxNYIiL2R7DluycZ0HYkk2drXQNmmDuz05HmXvFL5zilVqmoJXBqBJbMKFcHVxf4JC7xxbEqUTJYt+tPMuw/FXdkTk4oYjblTwDhk04MgJkVSAOjf1bUXBLJnxDZroAVXcAxvMM3fDh23xVllJw83mC4+Lhux8OyB5/gwdX6RQMzJr87uYNfh7mdWa/YIBX3ub4FDrQqarjw/2/JRqlqeHW/ttV8g30+MqvLJ+XM+zbalhVMwE9/BCPXnwWQ5nrz7j/9jbt4Q8AAAD//wMAUEsDBBQABgAIAAAAIQCcTl4h4gYAADocAAAaAAAAY2xpcGJvYXJkL3RoZW1lL3RoZW1lMS54bWzsWU9vG0UUvyPxHUZ7b+P/jaM6VezYDbRpo9gt6nG8Hu9OM7uzmhkn9Q21RyQkREEcqMSNAwIqtRKX8mkCRVCkfgXezOyud+I1SdsIKmgO8e7b37z/782b3ctX7kUMHRIhKY87XvVixUMk9vmExkHHuzUaXFj3kFQ4nmDGY9Lx5kR6Vzbff+8y3vAZTcYci8koJBFBwCiWG7jjhUolG2tr0gcylhd5QmJ4NuUiwgpuRbA2EfgIBERsrVaptNYiTGNvEzgqzajP4F+spCb4TAw1G4JiHIH0m9Mp9YnBTg6qGiHnsscEOsSs4wHPCT8akXvKQwxLBQ86XsX8eWubl9fwRrqIqRVrC+sG5i9dly6YHNSMTBGMc6HVQaN9aTvnbwBMLeP6/X6vX835GQD2fbDU6lLk2RisV7sZzwLIXi7z7lWalYaLL/CvL+nc7na7zXaqi2VqQPaysYRfr7QaWzUHb0AW31zCN7pbvV7LwRuQxbeW8INL7VbDxRtQyGh8sITWAR0MUu45ZMrZTil8HeDrlRS+QEE25NmlRUx5rFblWoTvcjEAgAYyrGiM1DwhU+xDTvZwNBYUawF4g+DCE0vy5RJJy0LSFzRRHe/DBMdeAfLy2fcvnz1Bx/efHt//6fjBg+P7P1pGzqodHAfFVS++/ezPRx+jP5588+LhF+V4WcT/+sMnv/z8eTkQymdh3vMvH//29PHzrz79/buHJfAtgcdF+IhGRKIb5Ajt8wgMM15xNSdj8WorRiGmxRVbcSBxjLWUEv59FTroG3PM0ug4enSJ68HbAtpHGfDq7K6j8DAUM0VLJF8LIwe4yznrclHqhWtaVsHNo1kclAsXsyJuH+PDMtk9HDvx7c8S6JtZWjqG90LiqLnHcKxwQGKikH7GDwgpse4OpY5fd6kvuORThe5Q1MW01CUjOnayabFoh0YQl3mZzRBvxze7t1GXszKrt8mhi4SqwKxE+RFhjhuv4pnCURnLEY5Y0eHXsQrLlBzOhV/E9aWCSAeEcdSfECnL1twUYG8h6NcwdKzSsO+yeeQihaIHZTyvY86LyG1+0AtxlJRhhzQOi9gP5AGkKEZ7XJXBd7lbIfoe4oDjleG+TYkT7tO7wS0aOCotEkQ/mYmSWF4l3Mnf4ZxNMTGtBpq606sjGv9d42YUOreVcH6NG1rl868flej9trbsLdi9ympm50SjXoU72Z57XEzo29+dt/Es3iNQEMtb1Lvm/K45e//55ryqns+/JS+6MDRoPYvYQduM3dHKqXtKGRuqOSPXpRm8Jew9kwEQ9TpzuiT5KSwJ4VJXMghwcIHAZg0SXH1EVTgMcQJDe9XTTAKZsg4kSriEw6Ihl/LWeBj8lT1qNvUhxHYOidUun1hyXZOzs0bOxmgVmANtJqiuGZxVWP1SyhRsex1hVa3UmaVVjWqmKTrScpO1i82hHFyemwbE3Jsw1CAYhcDLLTjfa9Fw2MGMTLTfbYyysJgonGeIZIgnJI2Rtns5RlUTpCxXlgzRdthk0AfHU7xWkNbWbN9A2lmCVBTXWCEui96bRCnL4EWUgNvJcmRxsThZjI46XrtZa3rIx0nHm8I5GS6jBKIu9RyJWQBvmHwlbNqfWsymyhfRbGeGuUVQhVcf1u9LBjt9IBFSbWMZ2tQwj9IUYLGWZPWvNcGt52VASTc6mxb1dUiGf00L8KMbWjKdEl8Vg12gaN/Z27SV8pkiYhhOjtCYzcQ+hvDrVAV7JlTC6w7TEfQNvJvT3jaP3OacFl3xjZjBWTpmSYjTdqtLNKtkCzcNKdfB3BXUA9tKdTfGvboppuTPyZRiGv/PTNH7Cbx9qE90BHx40Ssw0pXS8bhQIYculITUHwgYHEzvgGyB97vwGJIK3kqbX0EO9a+tOcvDlDUcItU+DZCgsB+pUBCyB23JZN8pzKrp3mVZspSRyaiCujKxao/JIWEj3QNbem/3UAipbrpJ2gYM7mT+ufdpBY0DPeQU683pZPnea2vgn558bDGDUW4fNgNN5v9cxXw8WOyqdr1Znu29RUP0g8WY1ciqAoQVtoJ2WvavqcIrbrW2Yy1ZXGtmykEUly0GYj4QJfAOCel/sP9R4TP7BUNvqCO+D70VwccLzQzSBrL6gh08kG6QljiGwckSbTJpVta16eikvZZt1uc86eZyTzhba3aWeL+is/PhzBXn1OJ5Ojv1sONrS1vpaojsyRIF0jQ7yJjAlH3J2sUJGgfVjgdfkyDQ9+AKvkd5QKtpWk3T4Ao+MsGwZL8Mdbz0IqPAc0vJMfWMUs8wjYzSyCjNjALDWfoNJqO0oFPpzybw2U7/eCj7QgITXPpFJWuqzue+zb8AAAD//wMAUEsDBBQABgAIAAAAIQCcZkZBuwAAACQBAAAqAAAAY2xpcGJvYXJkL2RyYXdpbmdzL19yZWxzL2RyYXdpbmcxLnhtbC5yZWxzhI/NCsIwEITvgu8Q9m7SehCRJr2I0KvUBwjJNi02PyRR7Nsb6EVB8LIws+w3s037sjN5YkyTdxxqWgFBp7yenOFw6y+7I5CUpdNy9g45LJigFdtNc8VZ5nKUxikkUigucRhzDifGkhrRykR9QFc2g49W5iKjYUGquzTI9lV1YPGTAeKLSTrNIXa6BtIvoST/Z/thmBSevXpYdPlHBMulFxagjAYzB0pXZ501LV2BiYZ9/SbeAAAA//8DAFBLAQItABQABgAIAAAAIQC75UiUBQEAAB4CAAATAAAAAAAAAAAAAAAAAAAAAABbQ29udGVudF9UeXBlc10ueG1sUEsBAi0AFAAGAAgAAAAhAK0wP/HBAAAAMgEAAAsAAAAAAAAAAAAAAAAANgEAAF9yZWxzLy5yZWxzUEsBAi0AFAAGAAgAAAAhAE33OYnvAgAAGwgAAB8AAAAAAAAAAAAAAAAAIAIAAGNsaXBib2FyZC9kcmF3aW5ncy9kcmF3aW5nMS54bWxQSwECLQAUAAYACAAAACEAnE5eIeIGAAA6HAAAGgAAAAAAAAAAAAAAAABMBQAAY2xpcGJvYXJkL3RoZW1lL3RoZW1lMS54bWxQSwECLQAUAAYACAAAACEAnGZGQbsAAAAkAQAAKgAAAAAAAAAAAAAAAABmDAAAY2xpcGJvYXJkL2RyYXdpbmdzL19yZWxzL2RyYXdpbmcxLnhtbC5yZWxzUEsFBgAAAAAFAAUAZwEAAGkNAAAAAA==" type="#_x0000_t202" o:spid="_x0000_s1026"></v:shape><TABLE cellSpacing=0 cellPadding=0 width="100%"><TBODY><TR><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0">«Supplier_Name»<o></o>
«Supplier_Address»

</TD></TR></TBODY></TABLE><o> </o>
<o> </o>
<o> </o>
<o> </o>
<o> </o>
<o> </o>


<o></o>
<o> </o>
<o> </o>
<o> </o>
Dear Sir/Madam<o></o>
<o> </o>
We regret that we are unable to process the below referred invoice for the following reason:<o></o>
<o> </o>
«Rejection_Reason»<o></o>
<o> </o>
<o> </o>
Accenture Ref: «URN»<o></o>
<o> </o>
Invoice Number: «Invoice_Number»<o></o>
<o></o>
Invoice Date: «Invoice_Date»<o></o>
<o> </o>
Invoice Amount: «Invoice_Amount» «Currency_code»<o></o>
<o> </o>
<o> </o>
Correct Details: <o></o>
<o> </o>
«Last_Comment»<o></o>
<o> </o>
<o> </o>
<o></o>
<o></o>
Request you to kindly amend your invoice accordingly and resend it to us at <o></o>
«DFM_Email_id» as soon as possible.<o></o>
<o> </o>
If you have any queries please do not hesitate to contact customer support at <o></o>
«Customer_care».<o></o>
<o> </o>
Yours sincerely<o></o>


Below is the VBA code i have written which is working fine except the Name and address not coming in TextBox.

Private Sub CommandButton1_Click()
Dim msg As String
Dim filename As String
Dim r As Integer
Dim lrow As Long
Dim wrdapp As Word.Application
Dim wrddoc As Word.Document
Dim strAddressData As String
Dim objShape As Shape

lrow = Worksheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row
For r = 3 To lrow
Set wrdapp = CreateObject("word.application")
wrdapp.Visible = True
Set wrddoc = wrdapp.Documents.Open("C:\Rejection\document1.docx")

With wrddoc
msg = ""
msg = msg & "To Finance Manager" & "," & vbCrLf

'msg = msg & ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 2.5, 1.5, _
116, 145).TextFrame.TextRange.Text = "Daniel" 'Worksheets("sheet1").Range("W" & r) & vbCrLf & vbCrLf & vbCrLf

msg = msg & "Dear Sir/Madam" & "," & vbCrLf & vbCrLf
msg = msg & "We regret that we are unable to process the below referred invoice for the following reason:" & " " & Worksheets("sheet1").Range("P" & r) & vbCrLf & vbCrLf

msg = msg & "Accenture Ref - " & Worksheets("sheet1").Range("A" & r) & vbCrLf
msg = msg & "Invoice Number - " & Worksheets("sheet1").Range("H" & r) & vbCrLf
msg = msg & "Invoice Date - " & Worksheets("sheet1").Range("I" & r) & vbCrLf
msg = msg & "Invoice Amount - " & Worksheets("sheet1").Range("J" & r) & "" & Worksheets("sheet1").Range("K" & r) & vbCrLf & vbCrLf & vbCrLf

msg = msg & "Correct Details" & vbCrLf
msg = msg & Worksheets("sheet1").Range("N" & r) & vbCrLf & vbCrLf & vbCrLf

msg = msg & "Request you to kindly amend your invoice accordingly and resend it to us at" & " " & Worksheets("sheet1").Range("V" & r) & "as soon as possible" & vbCrLf & vbCrLf
msg = msg & "If you have any queries please do not hesitate to contact customer support at" & " " & Worksheets("sheet1").Range("U" & r) & vbCrLf & vbCrLf & vbCrLf
msg = msg & "Yours sincerely" & vbCrLf & "Accenture Business Services."

.Content.InsertAfter msg
.Content.InsertParagraphAfter

filename = Worksheets("sheet1").Range("AA" & r)
'If Dir("C:\Rejection\filename.doc") <> "" Then
' Kill "C:\Foldername\filename.doc"
' End If
.SaveAs ("c:\Rejection\" & filename)
.Close
End With
' Sending Mails from Outlook
Dim olf As Outlook.MAPIFolder, olmailitem As Outlook.MailItem
Dim tocontact As Outlook.Recipient
Set olf = GetObject("", _
"outlook.application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olmailitem = olf.Items.Add
With olmailitem
.Subject = filename
Set tocontact = .Recipients.Add(Worksheets("sheet1").Range("X" & r))
Set tocontact = .Recipients.Add(Worksheets("sheet1").Range("Y" & r))
tocontact.Type = olCC
Set tocontact = .Recipients.Add(Worksheets("sheet1").Range("Z" & r))
Set tocontact = .Recipients.Add(Worksheets("sheet1").Range("Z" & r))
.body = "This is the Message text"
.Attachments.Add "c:\Rejection\" & filename & ".docx", olByValue, , _
Attachment

.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Save
.Send
End With

Next r

wrdapp.Quit
Set wrddoc = Nothing
Set wrdapp = Nothing

Set tocontact = Nothing
Set olmailitem = Nothing
Set olf = Nothing

End Sub


Please help me with VBA code i should put to have Name and address in Text Box in Word Document.

Thanks

 

[danpre]

Hi Team,

Could anyone of you help me on this issue.

Thanks