批量自动修改LINK域地址

qxnljx

在WORD中使用LINK域的都知道，如果被链接的Excel文件的存放位置发生变化，更新域后就会出现错误，有什么办法呢？
经过反复研究守柔版主的域代码相关知识及《Word非常接触》后，写了如后的代码，并测试成功，现与广大域代码爱好者分享。
要求：
一、插入域代码时，不要加“\a”开关（不自动更新）；
二、设置Word选项，使之打开时不自动更新域（Word选项－>高级－>常规－>打开时更新自动链接：不勾选）。

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By qxnljx, 2012-5-23 23:15
'仅测试于System: Windows 7 Word: 14.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub AutoOpen()
    If MsgBox("是否进行数据更新？", vbQuestion + vbYesNo + vbDefaultButton2, "温馨提示") = vbYes Then
        Application.ScreenUpdating = False
        Call UpdateLinkPath
        Application.ScreenUpdating = True
    End If
End Sub

Private Sub UpdateLinkPath()
    '默认：链接表与Word文档在同一目录下
    Dim UserFileName As Variant
    Dim fd As FileDialog
    Dim sField, c, cPath As String
    Dim i, n As Integer
    ActiveDocument.Fields(1).Select
    sField = ActiveDocument.Fields(1).Code
    i = InStr(1, sField, "房产销售与客户关系管理系统.xls", vbTextCompare)
    If i > 0 Then
        For n = 1 To i
            c = Mid(sField, n, 1)
            If c = ":" Then
                cPath = Mid(sField, n - 1, i - n + 1)
                If Dir(VBA.Replace(cPath, "\\", "\") & "房产销售与客户关系管理系统.xls", vbDirectory) = "" Then '当前目录下指定的表不存在
                    Set fd = Application.FileDialog(msoFileDialogFilePicker)
                    Dim vrtSelectedItem As Variant
                    With fd
                        If .Show = -1 Then
                            For Each vrtSelectedItem In .SelectedItems
                                UserFileName = vrtSelectedItem
                            Next vrtSelectedItem
                        Else
                        End If
                    End With
                    Set fd = Nothing
                    If UserFileName <> False Then
                        If InStr(1, UserFileName, "房产销售与客户关系管理系统.xls", vbTextCompare) > 0 Then
                            Call FindandReplace(cPath, VBA.Replace(Mid(UserFileName, 1, InStr(1, UserFileName, "房产销售与客户关系管理系统.xls", vbTextCompare) - 1), "\", "\\"))
                        Else
                            MsgBox "您打开的文件不是指定的表格文件！"
                            Exit Sub
                        End If
                    Else
                        MsgBox "您没有打开任何表格文件！"
                        Exit Sub
                    End If
                Else    '当前目录下指定的表存在
                    If StrComp(VBA.Replace(cPath, "\\", "\"), ThisDocument.Path & "\", vbTextCompare) <> 0 Then
                        '链接中的路径不是当前目录
                        Call FindandReplace(cPath, VBA.Replace(ThisDocument.Path & "\", "\", "\\"))
                    End If
                End If
                Exit For
            End If
        Next
    End If
    ActiveDocument.Fields.Update '执行更新动作
End Sub

Private Function FindandReplace(FindText As String, ReplaceText As String) As String
    Selection.WholeStory
    ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes '显示所有的域代码(切换方式):One Times!
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = FindText
        .Replacement.Text = ReplaceText
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes '显示所有的域结果(切换方式):Two Times!
End Function

注：默认Word档中的所有Link域均链接于同一个excel表。
欢迎测试，并发表您的测试结果。

qxnljx

对UpdateLinkPath函数做了一下优化和调整：
Private Sub UpdateLinkPath()
    '默认：链接表与合同文档在同一目录下！
    Dim UserFileName As Variant
    Dim fd As FileDialog
    Dim sField, c, cPath As String
    Dim i, n As Integer
    ActiveDocument.Fields(1).Select
    sField = ActiveDocument.Fields(1).Code
    i = InStr(1, sField, "房产销售与客户关系管理系统.xls", vbTextCompare)
    If i > 0 Then
        For n = 1 To i
            c = Mid(sField, n, 1)
            If c = ":" Then
                cPath = Mid(sField, n - 1, i - n + 1)
                If Dir(VBA.Replace(cPath, "\\", "\") & "房产销售与客户关系管理系统.xls", vbDirectory) = "" Then 'Link目录下指定的表不存在
                    If Dir(ThisDocument.Path & "\房产销售与客户关系管理系统.xls", vbDirectory) <> "" Then '当前目录下指定的表存在
                        '链接中的路径不是当前目录
                        Call FindandReplace(cPath, VBA.Replace(ThisDocument.Path & "\", "\", "\\"))
                    Else
                        If MsgBox("是否手动查找 Excel 文件？", vbQuestion + vbYesNo + vbDefaultButton1, "温馨提示") = vbYes Then
                            Set fd = Application.FileDialog(msoFileDialogFilePicker)
                            Dim vrtSelectedItem As Variant
                            With fd
                                If .Show = -1 Then
                                    For Each vrtSelectedItem In .SelectedItems
                                        UserFileName = vrtSelectedItem
                                    Next vrtSelectedItem
                                Else
                                End If
                            End With
                            Set fd = Nothing
                            If UserFileName <> False Then
                                If InStr(1, UserFileName, "房产销售与客户关系管理系统.xls", vbTextCompare) > 0 Then
                                    Call FindandReplace(cPath, VBA.Replace(Mid(UserFileName, 1, InStr(1, UserFileName, "房产销售与客户关系管理系统.xls", vbTextCompare) - 1), "\", "\\"))
                                Else
                                    MsgBox "您打开的文件不是指定的表格文件！"
                                    Exit Sub
                                End If
                            Else
                                MsgBox "您没有打开任何表格文件！"
                                Exit Sub
                            End If
                        Else
                            Exit Sub
                        End If
                    End If
                End If
                Exit For
            End If
        Next
    End If
    ActiveDocument.Fields.Update '执行更新动作
End Sub

alw1000

留个位置，只明白大致意思，我的文档就是经常会使用大量link域，一旦文档位置变了，link域就会全部挂掉，很是头疼。

请问lz的帖子作用何在？

qxnljx

就是要解决这个问题。打开文档后，会自动检查LINK域，如果指定的表不存在，会提示手动查找，并按您提供的表的地址来修改域。

alw1000

qxnljx 发表于 2012-8-21 22:50
就是要解决这个问题。打开文档后，会自动检查LINK域，如果指定的表不存在，会提示手动查找，并按您提供的表 ...

“如果指定的表不存在”
那我还想再请问下，如果指定的表存在，但我想把链接地址换到另外一个表，这样也行么？怎么操作呢？

qxnljx

alw1000 发表于 2012-9-13 13:29
“如果指定的表不存在”
那我还想再请问下，如果指定的表存在，但我想把链接地址换到另外一个表，这样也 ...

当然可以。一、把指定的表改名，这样就变成了“指定的表不存在了”；二、当提示手动查找时，选择您想链接的表即可。诚然，格式需要一样哟，不然，就涉及修改域的内容了，这不是本函数的主要目的，本函数主要修改LINK域中的“地址”。

alw1000

qxnljx 发表于 2012-9-18 22:42
当然可以。一、把指定的表改名，这样就变成了“指定的表不存在了”；二、当提示手动查找时，选择您想链接 ...

再次请教下，我的文档是一整个word，其中报告中部分数据直接引用word表格中直接计算的数值，采取的引用方法为“选择性粘贴---粘贴链接----无格式文本”这种形式，也适合你的这种方式么？谢谢

alw1000

alw1000 发表于 2012-9-21 09:51
再次请教下，我的文档是一整个word，其中报告中部分数据直接引用word表格中直接计算的数值，采取的引用方 ...

我现在报告中很多部分的引用链接错误，就是因为我把word转移到了其他路径中，例如说拷贝到u盘里带回家做，家里文档的路径就和公司文档路径不一样了，这样链接就全部挂掉了。很是头疼
word的这种超链接引用，全部是绝对路径引用，有没有什么相对引用的方式呢？例如说链接只在该word文件中寻找，word任意移动都没问题。

alw1000

qxnljx 发表于 2012-9-18 22:42
当然可以。一、把指定的表改名，这样就变成了“指定的表不存在了”；二、当提示手动查找时，选择您想链接 ...

我今天又对域链接进行了测试，把几种方式放一起对比。发现word的链接域能够随着文本的位置变动自动修正，我没有用你的代码。哎真奇了怪了，我把附件上传给你看看，我的引用可能跟你的不大一样，我只是对word内部数据进行引用，而你的代码是用来修改word对excel中的数据进行引用的，我可以这么理解吧？ 实验.zip (7.83 KB, 下载次数: 121)

2012-9-25 13:55 上传

点击文件名下载附件

qxnljx

alw1000 发表于 2012-9-21 09:51
再次请教下，我的文档是一整个word，其中报告中部分数据直接引用word表格中直接计算的数值，采取的引用方 ...

这种方式的引用与本函数的目的是不相同的。