Sub ObituaryCombinedMacro()
' Obituary Combined Macro
Application.ScreenUpdating = False
Dim Rng As Range, FmFld As FormField
Set Rng = Selection.Range
With ActiveDocument
.Bookmarks.Add Name:="Start"
  Rng.Collapse wdCollapseStart
  'Dropdown Menu for Record Collection
  Set FmFld = .FormFields.Add(Range:=Rng, Type:=wdFieldFormDropDown)
  With FmFld
    .Name = "ObituaryDD"
    .EntryMacro = ""
    .ExitMacro = "CondtionalContentObituaries"
    .Enabled = True
    With .DropDown.ListEntries
      .Add Name:="Obit Websites"
      .Add Name:="Ancestry"
      .Add Name:="Legacy"
      .Add Name:="ObitsforLife"
      .Add Name:="Obituaries.com"
      .Add Name:="Rootsweb"
      .Add Name:="Tributes"
      End With
      With Rng
     .End = FmFld.Range.End
     .Font.Italic = True
     .Collapse wdCollapseEnd
    End With
    End With
  .Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=Pwd
  End With
  Set FmFld = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub CondtionalContentObituaries()
Application.ScreenUpdating = False
Dim Prot As Variant, Rng As Range, FmFld As FormField
Const Pwd As String = ""
With ActiveDocument
  Prot = .ProtectionType
  If .ProtectionType <> wdNoProtection Then
    Prot = .ProtectionType
    .Unprotect Password:=Pwd
    With .FormFields("ObituaryDD")
      Set Rng = .Range.Paragraphs.First.Range
      Rng.MoveEnd wdCharacter, -1
      Rng.Start = .Range.End
    End With
    Select Case .FormFields("ObituaryDD").Result
       'Case for Tributes
      Case "Tributes"
      If InStr(Rng.Text, "") = 0 Then
      .Bookmarks.Add Name:="Middle"
      ActiveDocument.Bookmarks("Start").Range.InsertAfter "database, "
     ActiveDocument.Bookmarks("Start").Range.InsertBefore "United States Obituary Collection," & Chr(211)
        ActiveDocument.Bookmarks("Start").Range.InsertBefore Chr(210)
        ActiveDocument.Bookmarks("Middle").Range.Font.Italic = False
        With Rng
        .InsertAfter " (http://www.tributes.com : viewed " & _
          Format(Now, "D MMMM YYYY") & "), "
          .Font.Italic = False
          .Collapse wdCollapseEnd
          End With
           'Drop Down for Entry
    Set FmFld = .FormFields.Add(Range:=Rng, Type:=wdFieldFormDropDown)
    With FmFld
        .Name = "EntryDD"
        .EntryMacro = ""
        .ExitMacro = ""
        .Enabled = True
        With .DropDown.ListEntries
        .Add Name:="no entry for "
        .Add Name:="entry for "
        End With
    End With
     With Rng
     .End = FmFld.Range.End
     .Collapse wdCollapseEnd
         End With
           'Formfield for Firstname Lastname
        Set FmFld = .FormFields.Add(Range:=Rng, Type:=wdFieldFormTextInput)
        FmFld.TextInput.EditType wdRegularText, "Firstname Lastname", Format:="Title Case"
        With Rng
          .End = FmFld.Range.End
          .InsertAfter ", ("
          .Collapse wdCollapseEnd
          End With
          'Formfield for Death Year
        Set FmFld = .FormFields.Add(Range:=Rng, Type:=wdFieldFormTextInput)
        FmFld.TextInput.EditType wdRegularText, "Death Year"
        With Rng
         .End = FmFld.Range.End
          .InsertAfter ")."
          .Collapse wdCollapseEnd
            'Bookmark for End of Citation
           .Bookmarks.Add Name:="End"
           FmFld.ExitMacro = "UnlinkItalic"
           .Collapse wdCollapseEnd
           End With
           ActiveDocument.Bookmarks("ObituaryDD").Range.Font.Italic = True
           End If
      Case Else: Rng.Text = Chr(211)
    End Select
    .Protect Type:=Prot, Password:=Pwd, NoReset:=True
End If
End With
Set FmFld = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub UnlinkItalic()
'Unlink Database Macro
With ActiveDocument
 If .ProtectionType <> wdNoProtection Then
   .Unprotect Password:=Pwd
   End If
 Dim i As Long, FmFld As FormField, Rng As Range
 For Each FmFld In ActiveDocument.FormFields
 i = Len(FmFld.Result)
 Set Rng = FmFld.Range
 If FmFld.Range.Font.Italic = True Then
 Rng.Fields.Unlink
 Rng.End = Rng.End + i
 Rng.Font.Italic = True
 Else
   Rng.Fields.Unlink
   End If
   Next FmFld
lbl_Exit:
   Set FmFld = Nothing
   Set Rng = Nothing
    .GoTo What:=wdGoToBookmark, Name:="End"
          Dim Bookmark As Bookmark
      ActiveDocument.Bookmarks.ShowHidden = True
      If ActiveDocument.Bookmarks.Count >= 1 Then
         For Each Bookmark In ActiveDocument.Bookmarks
            Bookmark.Delete
         Next Bookmark
         Selection.MoveRight Unit:=wdCharacter, Count:=1
        End If
      End With
End Sub

Sub UnlinkItalic()
'Unlink Database Macro
Dim bItal As Boolean, Rng As Range
Const Pwd As String = ""
With ActiveDocument
  If .ProtectionType <> wdNoProtection Then
   .Unprotect Password:=Pwd
  End If
  While .FormFields.Count > 0
    Set Rng = .Bookmarks(.FormFields(1).Name).Range
    With Rng
      bItal = .Fields(1).Code.Font.Italic
      .End = .End + 1
      .Fields(1).Unlink
      .End = .End - 1
      .Font.Italic = bItal
    End With
  Wend
End With
End Sub