【转载】VBA从字符串中提取电子邮件的函数
时 间:2020-06-23 08:49:16
作 者:金宇 ID:43 城市:江阴
摘 要:通过正则表达式提取电子邮件。
正 文:
主要通过正则表达式来提取字符串中的电子邮件,代码如下:
'--------------------------------------------------------------------------------------- ' Procedure : ExtractEmailAddresses ' Author : Daniel Pineault, CARDA Consultants Inc. ' Website : http://www.cardaconsultants.com ' Purpose : Extract e-mail addresses from a supplied string ' Notes : None ' Copyright : The following is release as Attribution-ShareAlike 4.0 International ' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/ ' Req'd Refs: Uses Late Binding, so none required ' ' Input Variables: ' ~~~~~~~~~~~~~~~~ ' sInput : String to parse/extract e-mail addresses from ' ' Usage: ' ~~~~~~ ' See TestMe Sub ' ' Revision History: ' Rev Date(yyyy/mm/dd) Description ' ************************************************************************************** ' 1 2020-05-13 Initial Release, Forum Help ' 2 2020-05-17 Added a more advanced pattern '--------------------------------------------------------------------------------------- Public Function ExtractEmailAddresses(ByVal sInput As Variant) As Variant On Error GoTo Error_Handler Dim oregEx As Object Dim oMatches As Object Dim oMatch As Object Dim sEmail As String If Not IsNull(sInput) Then Set oregEx = CreateObject("vbscript.regexp") With oregEx 'Basic pattern '.Pattern = "([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+\.[a-zA-Z0-9_-]+)" 'More advanced pattern that allow accented characters .Pattern = "([a-zA-ZF0-9\u00C0-\u017F._-]+@[a-zA-Z0-9\u00C0-\u017F._-]+\.[a-zA-Z0-9\u00C0-\u017F_-]+)" .Global = True .IgnoreCase = True .MultiLine = True Set oMatches = .Execute(sInput) End With For Each oMatch In oMatches sEmail = oMatch.Value & "," & sEmail Next oMatch If Right(sEmail, 1) = "," Then sEmail = Left(sEmail, Len(sEmail) - 1) ExtractEmailAddresses = Split(sEmail, ",") 'Return an array of email addresses extracted from sInput Else ExtractEmailAddresses = Null End If Error_Handler_Exit: On Error Resume Next If Not oMatch Is Nothing Then Set oMatch = Nothing If Not oMatches Is Nothing Then Set oMatches = Nothing If Not oregEx Is Nothing Then Set oregEx = Nothing Exit Function Error_Handler: MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: ExtractEmailAddresses" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Function
附 件:
图 示:
Access软件网QQ交流群 (群号:483923997) Access源码网店
常见问答:
技术分类:
源码示例
- 【源码QQ群号19834647...(12.17)
- Access两种方式实现即时更...(03.01)
- Access隐藏与显示lacc...(01.12)
- 【Access高效办公】将每个...(12.23)
- Access21点游戏源代码(12.13)
- 【Access窗体导出Exce...(11.15)
- 【Access开发】Acces...(11.14)
- 通过Access宏录入数据到选...(11.10)
- 用DLOOKUP函数将需求表中...(10.31)
- Access日期区间段查询数据...(10.25)
学习心得
最新文章
- Access快速开发平台--在WI...(03.08)
- 使用SQL语句删除xscj表中学号...(03.08)
- Access快速开发平台进销存教程...(03.07)
- Access快速开发平台--frm...(03.06)
- 【Access删除查询】删除数字最...(03.06)
- Access快速开发平台进销存教程...(03.05)
- Access快速开发平台进销存教程...(03.04)
- Access快速开发平台--IsL...(03.02)
- Access两种方式实现即时更新月...(03.01)
- Access开发的资金管理系统;基...(02.29)