Sub SourcesExport()
Dim oSrc As Source, StrSrc As String
With ActiveDocument
  .Range.Text = vbNullString
  For Each oSrc In Application.Bibliography.Sources
    StrSrc = StrSrc & vbCr & oSrc.XML
  Next
  .Range.InsertAfter StrSrc
  .Paragraphs.First.Range.Delete
End With
End Sub
 
Sub SourcesImport()
Dim i As Long
'In case the source is already present
On Error Resume Next
With ActiveDocument
  For i = 0 To UBound(Split(.Range.Text, vbCr))
    Application.Bibliography.Sources.Add Split(.Range.Text, vbCr)(i)
  Next
End With
End Sub

Sub DeleteReferenceBuilingBlocks()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim i As Long, iRng As Long, StrCode As String
Dim Stry As Range, Rng As Range, Fld As Field, Stl As String
With ActiveDocument
  For Each Stry In .StoryRanges
    Select Case Stry.StoryType
      Case wdFootnotesStory, wdEndnotesStory, wdMainTextStory
        'loop through all fields, starting from the end of the story
        For i = Stry.Fields.Count To 1 Step -1
          With Stry.Fields(i)
            'get the field type
            If .Type = wdFieldCitation Then
              StrCode = Trim(.Code.Text)
              Set Rng = .Result.Duplicate
              iRng = Len(Rng.Text)
              .Select
              WordBasic.BibliographyCitationToText
              Rng.MoveEnd wdCharacter, iRng
              If Rng.Characters.First.Previous = " " Then
                Rng.Start = Rng.Start - 1
              End If
              Set Fld = Rng.Fields.Add(Range:=Rng, Type:=wdFieldEmpty, _
                Text:="REF " & StrCode, Preserveformatting:=False)
              Fld.Code.Text = Trim(Replace(Fld.Code.Text, "REF ", ""))
            ElseIf .Type = wdFieldBibliography Then
              StrCode = Trim(.Code.Text)
              Set Rng = .Result.Duplicate
              With Rng
                .MoveStart wdParagraph, -2
                Stl = .Paragraphs(1).Style
                .Start = .Start - 1
                .End = .End + 2
                .Text = vbNullString
                .Collapse wdCollapseStart
                .Text = vbCr & "Bibliography" & vbCr
                .Paragraphs(2).Style = Stl
                .Collapse wdCollapseEnd
              End With
              Set Fld = Rng.Fields.Add(Range:=Rng, Type:=wdFieldEmpty, _
                Text:=StrCode, Preserveformatting:=False)
            End If
          End With
        Next
        Stry.Fields.Update
      Case Else
    End Select
  Next
End With
Set Rng = Nothing: Set Fld = Nothing
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
End Sub

Sub References_Unlink()
Dim Fld As Field, FtNt As Footnote, EndNt As Endnote
With ActiveDocument
  For Each Fld In .Fields
    If Fld.Type = wdFieldCitation Then
      Fld.Select
      WordBasic.BibliographyCitationToText 
    ElseIf Fld.Type = wdFieldBibliography Then
      Fld.Select
      WordBasic.BibliographyCitationToText
    End If
  Next
  For Each FtNt In .Footnotes
    For Each Fld In FtNt.Range.Fields
      If Fld.Type = wdFieldCitation Then
        Fld.Select
        WordBasic.BibliographyCitationToText
      End If
    Next
  Next
  For Each EndNt In .Endnotes
    For Each Fld In EndNt.Range.Fields
      If Fld.Type = wdFieldCitation Then
        Fld.Select
        WordBasic.BibliographyCitationToText
      End If
    Next
  Next
End With
End Sub

Sub WriteBibliographyToFile()
  Dim xmlPart As CustomXMLPart
  Dim sFilename As String
  
'  For Each xmlPart In ActiveDocument.CustomXMLParts
'    Debug.Print xmlPart.ID & vbTab & xmlPart.NamespaceURI
'  Next xmlPart
  
  Set xmlPart = ActiveDocument.CustomXMLParts.SelectByNamespace("http://schemas.openxmlformats.org/officeDocument/2006/bibliography").Item(1)
  If Not xmlPart Is Nothing Then
    sFilename = ActiveDocument.Path & "\Bibliography.xml"
    'Debug.Print xmlPart.XML
    Call WriteStringToFile(sFilename, xmlPart.XML)
  End If

End Sub
Sub WriteStringToFile(pFileName As String, pString As String)
  Dim intFileNum As Integer
  intFileNum = FreeFile
  Open pFileName For Output As intFileNum
    Print #intFileNum, pString
  Close intFileNum
End Sub