Outlook表格超链接Text To Display按行递增编号需求及代码修改

问题说明 #

原VBA脚本可将Outlook邮件表格选中区域内的单元格内容转为超链接，并自定义显示文本，但当前实现为全局递增编号（所有选中单元格从1连续计数），需求调整为按每行单独递增编号（每行从1开始重新计数）。

原代码 #

Sub Hyperlink_Outlook()

  Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Cell, i As Long
  
  Set wDoc = Application.ActiveInspector.WordEditor
  Set rngSel = wDoc.Windows(1).Selection
    
  If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
    If rngSel.Range.Cells.Count > 0 Then
       For Each cel In rngSel.Cells
         If Len(cel.Range.Text) > 10 Then
           i = i + 1
            wDoc.Hyperlinks.Add cel.Range, _
             Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
             TextToDisplay:="Attachment " & i
         End If
       Next
    End If
  End If
  
End Sub

修改后的代码 #

Sub Hyperlink_Outlook_PerRow()

  Dim wDoc As Word.Document, rngSel As Word.Selection, cel As Cell
  Dim i As Long, currentRow As Long
  
  Set wDoc = Application.ActiveInspector.WordEditor
  Set rngSel = wDoc.Windows(1).Selection
    
  If Not rngSel Is Nothing And rngSel.Information(wdWithInTable) Then
    If rngSel.Range.Cells.Count > 0 Then
       ' 初始化行号和计数
       currentRow = -1
       i = 0
       
       For Each cel In rngSel.Cells
         If Len(cel.Range.Text) > 10 Then
           ' 判断当前单元格是否属于新行，是则重置计数
           If cel.RowIndex <> currentRow Then
             currentRow = cel.RowIndex
             i = 0
           End If
           
           i = i + 1
           wDoc.Hyperlinks.Add cel.Range, _
             Address:=Left(cel.Range.Text, Len(cel.Range.Text) - 1), _
             TextToDisplay:="Attachment " & i
         End If
       Next
    End If
  End If
  
End Sub

修改说明 #

1. 新增currentRow变量跟踪当前处理的行号，初始值设为-1确保第一行触发重置
2. 遍历单元格时，先判断当前单元格的行号是否与currentRow一致：
   • 不一致说明进入新行，重置i为0并更新currentRow
   • 一致则继续累加计数
3. 保留原有的超链接地址提取和添加逻辑，仅调整编号的计数规则，实现每行独立从1开始递增

内容的提问来源于stack exchange，提问作者Peace