Copy value from RTF content control and paste it into filename

[CJSimon]

Hi there. I'd appreciate some help please, if possible. I've created a Word macro that's activated by a button click (within the Word document). The end user clicks on the button, it saves a copy of the file to their desktop with a specific naming convention, opens an email in Outlook (desktop app), attaches the copy of the Word doc, and fills out the email with all of the applicable info. Those pieces all work fine.

What I'm struggling with is a new "enhancement" request to the process. I need to update the macro to also copy data from a specific field in the Word document (a rich text content control) and then paste that data into the file name when the macro runs the save as function. This pasted data is the ID # of the submission, which the user is required to input into the aforementioned content control (Content Control Title = "SubmissionIDNo" and Tag also = "SubmissionIDNo").

I've never done this particular function in Word before. I've tried more VBA combinations than I care to admit so far and can get close, but not quite there. At this point, my brain is fried and I think I'm just making it worse. I've looked all over various forums and haven't found anything that explicitly addresses this use case, but I'm not a VBA expert by any means, so it could just be my misunderstanding of an already-solved problem.



Anyway, below is my code. Again, any help would be greatly appreciated. Many thanks in advance.

Private Sub CommandButton1_Click()

Call FindCCbyTitleAndTag
Dim StrPath As String
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
ActiveDocument.SaveAs DTAddress & "CCB Proposal Submission ID # " & SubmissionIDNo, FileFormat:=wdFormatXMLDocument

Dim OL          As Object
Dim EmailItem   As Object
Dim Doc         As Document

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save

MsgBox "Your CCB proposal document has been saved to your desktop as 'CCB Proposal Submission ID # (plus the applicable ID #)'. Click 'OK' to open your submission email draft."

With EmailItem
    .Subject = Doc
    .Subject = Replace(Doc, ".docx", "")
    .Body = "Greetings," & vbCrLf & vbCrLf & _
    "Attached please find a CCB proposal submission." & vbCrLf & vbCrLf & _
    "Please let me know if you have any questions." & vbCrLf & vbCrLf & _
    "Thank you."
    .To = "NAME_REDACTED"
    .CC = "NAME_REDACTED"
    .Attachments.Add Doc.FullName
    .Display

End With

Application.ScreenUpdating = True

Set Doc = Nothing
Set OL = Nothing

End Sub


Private Function FindCCbyTitleAndTag()
  Dim Title As ContentControl
  Dim Tag As ContentControl
  Dim CC As ContentControl
  For Each CC In ActiveDocument.ContentControls
    If CC.Title = SubmissionIDNo And CC.Tag = SubmissionIDNo Then
      Call GetClip
    End If
  Next CC
End Function


Private Function GetClip() As String
Dim MyData As New DataObject
Dim strClip As String
    Set MyData = New DataObject
    MyData.GetFromClipboard
    strClip = MyData.GetText
    GetClip = strClip
End Function