ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > 我的酷贴 > Word > 分享在WORD中查找手机、固话、邮址的自定义函数

分享在WORD中查找手机、固话、邮址的自定义函数

作者：绿色风 分类： 时间：2022-08-18 浏览：190
楼主
chenlifeng		 通过反复测试，下面三个自定义函数，能把当前WORD中的手机、固话、邮箱地址，全部匹配出来，特作分享，谢谢！
  1. Function 调用固话() As String
  2.     Dim RegExp As Object, str, mMatch
  3.     str = ActiveDocument.range.text
  4.     Set RegExp = CreateObject("vbscript.regexp")   
  5.     With RegExp
  6.         .Global = True
  7.         .IgnoreCase = True
  8.         .Pattern = "((0[0-9]{2,3})?(\-|\_|[ ]{0,})?([2-9][0-9]{3})+([ ]{0,})?([0-9]{3,4})+((\-|_|转| {0,}|分机)[0-9]{1,4})?)" '"(0[0-9]{2,3})?(-|_|[ ]{0,})?([2-9][0-9]{3})+([ ]{0,})?([0-9]{3,4})+((\-|_|转| {0,}|分机)[0-9]{1,4})?"
  9.     End With   
  10.     If RegExp.test(str) Then
  11.         For Each mMatch In RegExp.Execute(str)
  12.             If Len(GetNum(mMatch.Value, 1)) = 7 Or Len(GetNum(mMatch.Value, 1)) = 8 Or Len(GetNum(mMatch.Value, 1)) = 11 Or Len(GetNum(mMatch.Value, 1)) = 12 Or Len(GetNum(mMatch.Value, 1)) = 13 Or Len(GetNum(mMatch.Value, 1)) = 14 Or Len(GetNum(mMatch.Value, 1)) = 15 Or Len(GetNum(mMatch.Value, 1)) = 16 Then
  13.                With Selection.Find
  14.                    .text = mMatch
  15.                    .Wrap = wdFindContinue
  16.                End With
  17.                Selection.Find.Execute            
  18.                Selection.MoveLeft Unit:=wdCharacter, Count:=1
  19.                Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
  20.                Dim 前范围, 后范围, Reg As Object
  21.                    前范围 = Selection
  22.                    Selection.MoveRight Unit:=wdCharacter, Count:=1
  23.                    Selection.MoveRight Unit:=wdCharacter, Count:=Len(mMatch)
  24.                    Selection.MoveRight Unit:=wdCharacter, Count:=4, Extend:=wdExtend
  25.                    后范围 = Selection
  26.                Set Reg = CreateObject("vbscript.regexp")
  27.                With Reg
  28.                    .Global = True
  29.                    .IgnoreCase = False
  30.                    .MultiLine = True
  31.                    .Pattern = "固话|固|电话|座机|座|家庭|庭"
  32.                End With
  33.                If Reg.test(前范围 & 后范围) Then
  34.                   调用固话 = Replace(调用固话, " ", "") & "；" & mMatch.Value
  35.                Else
  36.                   If (Len(GetNum(mMatch.Value, 1)) = 16 Or Len(GetNum(mMatch.Value, 1)) = 15 Or Len(GetNum(mMatch.Value, 1)) = 12 Or Len(GetNum(mMatch.Value, 1)) = 11) And Mid(GetNum(mMatch.Value, 1), 1, 1) = 0 And InStr(前范围, "证") = 0 And InStr(前范围, "编") = 0 And InStr(后范围, "(证") = 0 And InStr(后范围, "(编") = 0 Then
  37.                       调用固话 = Replace(调用固话, " ", "") & "；" & mMatch.Value
  38.                   ElseIf (Len(GetNum(mMatch.Value, 1)) = 8 Or Len(GetNum(mMatch.Value, 1)) = 7) And Mid(GetNum(mMatch.Value, 1), 1, 1) > 1 And InStr(前范围, "证") = 0 And InStr(前范围, "编") = 0 And InStr(后范围, "(证") = 0 And InStr(后范围, "(编") = 0 Then
  39.                       调用固话 = Replace(调用固话, " ", "") & "；" & mMatch.Value
  40.                   End If
  41.                End If               
  42.             End If
  43.         Next mMatch
  44.     Else
  45.         调用固话 = "没有固定电话，或输错位数与空位置错"
  46.     End If
  47.     Selection.HomeKey Unit:=wdStory '把光标移动的文档首
  48.     If Mid(调用固话, 1, 1) = "；" Then
  49.        调用固话 = "固话：" & Mid(调用固话, 2, Len(调用固话) - 1)
  50.     Else: 调用固话 = IIf(调用固话 = "", "固话：可能不存在", "固话：" & 调用固话)
  51.     End If
  52. End Function


  55. Function 调用手机() As String
  56.     Dim RegExp As Object, str, mMatch
  57.     str = ActiveDocument.range.text
  58.     Set RegExp = CreateObject("vbscript.regexp")   
  59.     With RegExp
  60.         .Global = True
  61.         .IgnoreCase = True
  62.         .Pattern = "(((\+86)|(86))?([ ]{0,})?(13|14|15|18)+(\d{1})+([ ]{0,})?(\d{4})+([ ]{0,})?(\d{4})+|((\+86)|(86))?([ ]{0,})?(13|14|15|18)+(\d{2})+([ ]{0,})?(\d{4})+([ ]{0,})?(\d{3})+)"
  63.     End With   
  64.     If RegExp.test(str) Then
  65.         For Each mMatch In RegExp.Execute(str)
  66.             If Len(GetNum(mMatch.Value, 1)) = 11 Or Len(GetNum(mMatch.Value, 1)) = 13 Or Len(GetNum(mMatch.Value, 1)) = 14 Then
  67.                With Selection.Find
  68.                    .text = mMatch
  69.                    .Wrap = wdFindContinue
  70.                End With
  71.                Selection.Find.Execute            
  72.                Selection.MoveLeft Unit:=wdCharacter, Count:=1
  73.                Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
  74.                Dim 前范围, 后范围, Reg As Object
  75.                    前范围 = Selection
  76.                    Selection.MoveRight Unit:=wdCharacter, Count:=1
  77.                    Selection.MoveRight Unit:=wdCharacter, Count:=Len(mMatch)
  78.                    Selection.MoveRight Unit:=wdCharacter, Count:=4, Extend:=wdExtend
  79.                    后范围 = Selection
  80.                Set Reg = CreateObject("vbscript.regexp")
  81.                With Reg
  82.                    .Global = True
  83.                    .IgnoreCase = False
  84.                    .MultiLine = True
  85.                    .Pattern = "手机|手|ell|hon|all|ber"
  86.                End With
  87.                If Reg.test(前范围 & 后范围) Then
  88.                   调用手机 = Replace(调用手机, " ", "") & "；" & mMatch.Value
  89.                Else
  90.                   If Len(GetNum(mMatch.Value, 1)) = 14 And Mid(GetNum(mMatch.Value, 1), 1, 3) = "+86" And InStr(前范围, "证") = 0 And InStr(前范围, "编") = 0 And InStr(后范围, "(证") = 0 And InStr(后范围, "(编") = 0 Then
  91.                       调用手机 = Replace(调用手机, " ", "") & "；" & mMatch.Value
  92.                   ElseIf Len(GetNum(mMatch.Value, 1)) = 13 And Mid(GetNum(mMatch.Value, 1), 1, 3) = "86" And InStr(前范围, "证") = 0 And InStr(前范围, "编") = 0 And InStr(后范围, "(证") = 0 And InStr(后范围, "(编") = 0 Then
  93.                       调用手机 = Replace(调用手机, " ", "") & "；" & mMatch.Value
  94.                   ElseIf Len(GetNum(mMatch.Value, 1)) = 11 And InStr(前范围, "证") = 0 And InStr(前范围, "编") = 0 And InStr(后范围, "(证") = 0 And InStr(后范围, "(编") = 0 Then
  95.                       调用手机 = Replace(调用手机, " ", "") & "；" & mMatch.Value
  96.                   End If
  97.                End If               
  98.             End If
  99.         Next mMatch
  100.     Else
  101.         调用手机 = "没有手机号码，或输错号码与位数"
  102.     End If
  103.     Selection.HomeKey Unit:=wdStory '把光标移动的文档首
  104.     If Mid(调用手机, 1, 1) = "；" Then
  105.        调用手机 = "手机：" & Mid(调用手机, 2, Len(调用手机) - 1)
  106.     Else: 调用手机 = IIf(调用手机 = "", "手机：可能不存在", "固话：" & 调用手机)
  107.     End If
  108. End Function



  112. Function 调用邮箱() As String
  113.     Dim RegExp As Object, str, mMatch
  114.     str = ActiveDocument.range.text
  115.     Set RegExp = CreateObject("vbscript.regexp")   
  116.     With RegExp
  117.         .Global = True
  118.         .IgnoreCase = True
  119.         .Pattern = "(([\w-\.]+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([\w-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?))"
  120.     End With   
  121.     If RegExp.test(str) Then
  122.         For Each mMatch In RegExp.Execute(str)            
  123.                With Selection.Find
  124.                    .text = mMatch
  125.                    .Wrap = wdFindContinue
  126.                End With
  127.                Selection.Find.Execute            
  128.                Selection.MoveLeft Unit:=wdCharacter, Count:=1
  129.                Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
  130.                Dim 前范围, 后范围, Reg As Object
  131.                    前范围 = Selection
  132.                    Selection.MoveRight Unit:=wdCharacter, Count:=1
  133.                    Selection.MoveRight Unit:=wdCharacter, Count:=Len(mMatch)
  134.                    Selection.MoveRight Unit:=wdCharacter, Count:=4, Extend:=wdExtend
  135.                    后范围 = Selection
  136.                Set Reg = CreateObject("vbscript.regexp")
  137.                With Reg
  138.                    .Global = True
  139.                    .IgnoreCase = False
  140.                    .MultiLine = True
  141.                    .Pattern = "邮箱|电子|邮件|mail|邮|地址|址"
  142.                End With
  143.                If Reg.test(前范围 & 后范围) Then
  144.                   调用邮箱 = 调用邮箱 & "；" & mMatch.Value
  145.                Else
  146.                   If InStr(前范围, "网络") = 0 And InStr(前范围, "网页") = 0 And InStr(后范围, "(网络") = 0 And InStr(后范围, "(网页") = 0 Then 调用邮箱 = 调用邮箱 & "；" & mMatch.Value
  147.                End If
  148.         Next mMatch
  149.     Else
  150.         调用邮箱 = "没有电子邮箱，或漏输入了“@”"
  151.     End If
  152.     Selection.HomeKey Unit:=wdStory '把光标移动的文档首
  153.     If Mid(调用邮箱, 1, 1) = "；" Then
  154.        调用邮箱 = "邮箱：" & Mid(调用邮箱, 2, Len(调用邮箱) - 1)
  155.     Else: 调用邮箱 = IIf(调用邮箱 = "", "邮箱：可能不存在", "邮箱：" & 调用邮箱)
  156.     End If
  157. End Function
2楼
herelazy		 真是太棒啦，非常实用，感谢楼主分享啊！

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap