求助：如何实现批量查找并自动加入超链接！

medpower

请教一个关于如何实现批量查找并自动加入超链接的问题！

请看附件示例，有两个文件，其中需要查找并添加的超链接内容存放在一access数据库中，如果word文档中找到相应的内容则自动添加相对应的超链接地址，不知如何用VBA实现，谢谢！

另外，可不可以只对示例文档中用蓝色标记的文本进行操作，如果数据库中有相对应项的话？十分感谢 ！

EiAQo7fI.rar (14.01 KB, 下载次数: 155)

2007-7-25 15:05 上传

点击文件名下载附件
求助：如何实现批量查找并自动加入超链接！

medpower

怎么没有人回啊！自己写了以下代码，以基本可以实现，但只能将找到的第一个符合条件的进行添加超链接，请版主，各位朋友帮忙看看，如何能将所有符合条件的进行操作，谢谢！

Private Sub CommandButton3_Click()
    Dim CNN, RS1
    Dim strSQL1$, strFind$
    Dim myRange As Range
   
    Set CNN = CreateObject("Adodb.Connection")
    Set RS1 = CreateObject("Adodb.Recordset")
    strPath = ThisDocument.Path & "\TOC.mdb"
    CNN.Provider = "Microsoft.Jet.OLEDB.4.0"
    CNN.Open "Data Source =" & strPath & ";Jet OLEDB:Database Password=" & ""
   
    strSQL1 = "select * from TOC"
    RS1.Open strSQL1, CNN, 1, 3
   
    Application.ScreenUpdating = False
    For i = 1 To RS1.RecordCount
        strFind = RS1.Fields("TLFNO")
        Set myRange = ActiveDocument.Content
        With myRange.Find
            .ClearFormatting
            .Format = True
            .Font.Color = wdColorBlue
            .Text = RS1.Fields("TLFNO")
            If .Execute(findtext:=strFind) = True Then
                myRange.Select
                ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=RS1.Fields("LinkAddress"), _
                SubAddress:="", ScreenTip:="", TextToDisplay:=RS1.Fields("TLFNO")
            End If
        End With
        RS1.movenext
    Next
   
    Application.ScreenUpdating = True
    RS1.Close
End Sub

[此贴子已经被作者于2007-7-25 17:33:00编辑过]

medpower

怎么没有人帮我啊！

medpower

WNo8Eb88.rar (18.04 KB, 下载次数: 46)

2007-7-26 10:13 上传

点击文件名下载附件
求助：如何实现批量查找并自动加入超链接！

请各位朋友帮忙看看，为什么是个死循环，不能实现预期功能？

谢谢

cuteword

Private Sub CommandButton3_Click()
    Dim CNN, RS1
    Dim strSQL1$, strFind$
    Dim myRange As Range, lngEnd As Long, TF As Boolean, i As Integer, Exist As Boolean
   
    Set CNN = CreateObject("Adodb.Connection")
    Set RS1 = CreateObject("Adodb.Recordset")
    strPath = ThisDocument.Path & "\TOC.mdb"
    CNN.Provider = "Microsoft.Jet.OLEDB.4.0"
    CNN.Open "Data Source =" & strPath & ";Jet OLEDB:Database Password=" & ""
   
    strSQL1 = "select * from TOC"
    RS1.Open strSQL1, CNN, 1, 3
   
    Application.ScreenUpdating = False
    For i = 1 To RS1.RecordCount
'        If Selection.Type = wdSelectionIP Then
'            Set myRange = ActiveDocument.Content
'        Else
'            Set myRange = Selection.Range
'        End If
      '  Set myRange = ActiveDocument.Content
     '   lngEnd = myRange.End
       Selection.HomeKey wdStory
        With Selection.Find
            .ClearFormatting
            .Format = True
            .Font.Color = wdColorBlue
            .Text = RS1.Fields("TLFNO")
            .Forward = True
            Do While .Execute
  '              myRange.Select
             '   myRange.SetRange myRange.End, lngEnd
                ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=RS1.Fields("LinkAddress"), _
                SubAddress:="", ScreenTip:="", TextToDisplay:=RS1.Fields("TLFNO")
                Selection.MoveRight
            Loop
        End With
        RS1.movenext
    Next
   
    Application.ScreenUpdating = True
    RS1.Close
End Sub

medpower

谢谢楼上，但你的不能实现预期功能，chylhr兄已帮我解决，请参阅以下代码：

Private Sub CommandButton1_Click()
   Dim CNN, RS1
    Dim strSQL1$, strFind$, strHyperlink$, strPath$
    Dim myRange As Range, TF As Boolean, i As Integer, Exist As Boolean
    Dim Lc As Integer, Count As Integer
   
    Set CNN = CreateObject("Adodb.Connection")
    Set RS1 = CreateObject("Adodb.Recordset")
    strPath = ActiveDocument.Path & "\TOC.mdb"
    CNN.Provider = "Microsoft.Jet.OLEDB.4.0"
    CNN.Open "Data Source =" & strPath & ";Jet OLEDB:Database Password=" & ""
   
    strSQL1 = "select * from TOC"
    RS1.Open strSQL1, CNN, 1, 3
    For i = 1 To RS1.RecordCount
       Set myRange = ActiveDocument.Content
       strFind = RS1.Fields("TLFno")
       strHyperlink = RS1.Fields("LinkAddress")
       Count = 0
       myRange.Find.ClearFormatting
       Do While myRange.Find.Execute(findtext:=strFind, Wrap:=wdFindStop, Forward:=True)
          Count = Count + 1
          ActiveDocument.Hyperlinks.Add Anchor:=myRange, Address:=strHyperlink, _
          SubAddress:="", ScreenTip:="", TextToDisplay:=strFind
          myRange.SetRange Start:=myRange.End + Len(strFind) + 1, End:=ActiveDocument.Content.End
          '估计是Word查找的Bug，Start取值在myRange.End与myRange.End + Len(strFind)之间竟然会查找到以查找范围前面的那个strFind。
          '另外，在End的取值中使用动态的ActiveDocument.Content.End要比静态的lngEnd更合适
       Loop
       MsgBox strFind & ":" & CStr(Count)
       RS1.movenext
    Next
    RS1.Close
End Sub

feifeia

很好啊！谢谢！

xbq602

来学习一下代码！！！！！

ww0000

medpower 发表于 2007-7-27 09:29
谢谢楼上，但你的不能实现预期功能，chylhr兄已帮我解决，请参阅以下代码：Private Sub CommandButton1_Cli ...

能不能改成根据Excel表中的A列和B列批量设置链接呀？