How do I extract the username out of an email address in VBA?
For example - if my email ID is "prateek#gmail.com", then the username is "prateek".
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "\w+#gmail\.com"
.Global = True
End With
If Reg1.Test(emailAddress) Then
Set M1 = Reg1.Execute(emailAddress)
For Each M In M1
' M.SubMatches(1) is the (\w*) in the pattern
' use M.SubMatches(2) for the second one if you have two (\w*)
Debug.Print M.SubMatches(1)
Next
End If
It doesn't look like this got any submatch.
Try the code below, insread of RegEx you could use Left combined with Instr.
Dim usern As String
'emailAddress = "prateek#gmail.com" ' <-- for debug
usern = Left(emailAddress, InStr(emailAddress, "#") - 1)
MsgBox "UserName is " & usern
Related
I have to get username from MeetingItem.Recipient, I tried following to get it:
CStr(MeetingItem.Recipient.Address) and got this responce:
"/o=POST/ou=Zuerich/cn=Recipients/cn=eicherr" I have to do loop through all
recipients and get usernames for example if i do loor with code above Ill get:
"/o=POST/ou=Zuerich/cn=Recipients/cn=eicherr"
"/o=POST/ou=Group (FYHF23PDLT)/cn=Recipients/cn=kisslingie0e"
"/o=POST/ou=Group (FYHF23PDLT)/cn=Recipients/cn=katzensteink"
"/O=POST/OU=Bern/cn=Recipients/cn=junkerb"
"/o=POST/ou=Group (FYHF23PDLT)/cn=Recipients/cn=tanzg6a7"
I need only last part of this strings, how can i do that?
note: kisslingie0e and tanzg6a7 this nicknames contains at the end unnecessary three characters that must also be avoided
Or is there another way to get usernames from MeetingItem.Recipient.Adress.
To get Email I did following:
For Each recip In recips
'Obtain the E-mail Address of a Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set pa = recip.PropertyAccessor
Dim email as String
email = CStr(pa.GetProperty(PR_SMTP_ADDRESS))
Debug.Print email
End For
Use Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress to get the SMTP address.
Be prepared to handle nulls and errors.
To get the NT login name (domain account), read the PR_ACCOUNT MAPI property (DASL name http://schemas.microsoft.com/mapi/proptag/0x3A00001F) using Recipient.AddressEntry.PropertyAccessor.GetProperty.
You can also use Recipient.AddressEntry.GetExchangeUser().Alias
The easiest way to remove the leading text is to reverse the string and loop until you find a "/":
Dim email As String, username As String
Dim i As Integer
email = "/o=POST/ou=Group (FYHF23PDLT)/cn=Recipients/cn=kisslingie0e"
'Reverse string
email = StrReverse(email)
'Loop through string until / is found
For i = 1 To Len(email) Step 1
If Mid(email, i, 1) = "/" Then
Exit For
Else
username = username & Mid(email, i, 1)
End If
Next i
'Reverse username
username = StrReverse(username)
If you need to remove the "cn=", do something like this:
username = Split(username, "=")(1)
If the usernames never contain any numbers, you could remove the trail like this:
For i = 1 To Len(username) Step 1
'Loop until a number occurs
If IsNumeric(Mid(username, i, 1)) Then
'Use string until the number
username = Mid(username, 1, i - 1)
Exit For
End If
Next i
Here's another suggestion that works IF the source is consistent in having "Recipients/cn=" just prior to the desired string, it is followed by optionally stripping the last characters if they are numeric in the third or second to last character.
'find the location of constant, set vEM
vLoc = InStr(email, "Recipients/cn=")
vEM = Mid(email, vLoc + 14, 50)
'Check if third to last or second to last character is numeric
vOffset = 0
If IsNumeric(Mid(vEM, Len(vEM) - 2, 1)) Then
vOffset = 3
ElseIf IsNumeric(Mid(vEM, Len(vEM) - 1, 1)) Then
vOffset = 2
Else
vOffset = 0
End If
vEM = Left(vEM, Len(vEM) - vOffset)
my Question is how to check if a string have a "text" & "_" at beginning.
For Example:
If sText = test.docx Then Function = False
ElseIF sText = Test_test.docx Then Function = True
End If
how i cut this string correctly, also when the text before the _ is not test and if there are several _ in the string it also works
use Instr() as shown here:
foo="test"&"_"
bar="test_test.docx"
if Instr(bar, foo)>0 then function = true
else function = false
end if
Instr(bar,foo) shows position of substring foo in string bar.
If there s no such substring, then it returns zero
If you need to check any text, that is not a problem, use this condition:
foo="_"
n=4
bar"test_textt.docx"
m=Instr(bar,foo)
if (m>n)and(len(bar)>m) then function=true
else function=false
end if
here n - number of characters, that would be before ""
If you dont know how many characters there may be, just set n to 0 or 1
if "" migth be last character, then delete condition (len(bar)>m)
You can simply check if the string begin with test_
dim res as boolean, filename as string
res = false
filename = ""
' if the len is not Superior to 5 (len of test_), don't check
if len(sText) > 5 then
' if the left part begin with test_
if left(lcase(sText), 5) = "test_" then
res = true
' if you want to retrieve the filename without test
filename = mid(sText, 6)
end if
end if
I'm trying to delete string content before a certain word contained within the string. For example
master_of_desaster#live.de
I'd like to use VBA in order to replace that with
master_of_desaster
Everything after the "word" (#) should be removed, including the "word" itself.
I found a similar topic here, but he asks the opposite.
email = "master_of_desaster#live.de"
ret = Left(email, InStr(1, email, "#") - 1)
Result: master_of_desaster
Thanks to Shai Rado
=split("master_of_desaster#live.de","#")(0)
Just for fun - a regex approach.
Public Sub reg()
Dim re_pattern As String
Dim re As RegExp
Dim email As String
Dim match As Object
Set re = New RegExp
email = "master_of_desaster#live.de"
re_pattern = "(.*)#.*"
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = re_pattern
End With
Set match = re.Execute(email)
Debug.Print match.Item(0).SubMatches(0)
End Sub
A bit hacky but fast ( most Windows API accept zero terminated strings )
ret = Replace("master_of_disaster#live.de", "#", vbNullChar, , 1) ' Chr(0)
I usually use the Split method but with Limit:
ret = Split("master_of_disaster#live.de", "#", 2)(0)
ret = evaluate("left(" & string & ", search(""#"", " & string & ") - 1)")
I am trying to remove words appearing in one string from a different string using a custom function. For instance:
A1:
the was why blue hat
A2:
the stranger wanted to know why his blue hat was turning orange
The ideal outcome in this example would be:
A3:
stranger wanted to know his turning orange
I need to have the cells in reference open to change so that they can be used in different situations.
The function will be used in a cell as:
=WORDREMOVE("cell with words needing remove", "cell with list of words being removed")
I have a list of 20,000 rows and have managed to find a custom function that can remove duplicate words (below) and thought there may be a way to manipulate it to accomplish this task.
Function REMOVEDUPEWORDS(txt As String, Optional delim As String = " ") As String
Dim x
'Updateby20140924
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each x In Split(txt, delim)
If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
Next
If .Count > 0 Then REMOVEDUPEWORDS = Join(.keys, delim)
End With
End Function
If you can guarantee that your words in both strings will be separated by spaces (no comma, ellipses, etc), you could just Split() both strings then Filter() out the words:
Function WORDREMOVE(ByVal strText As String, strRemove As String) As String
Dim a, w
a = Split(strText) ' Start with all words in an array
For Each w In Split(strRemove)
a = Filter(a, w, False, vbTextCompare) ' Remove every word found
Next
WORDREMOVE = Join(a, " ") ' Recreate the string
End Function
You can also do this using Regular Expressions in VBA. The version below is case insensitive and assumes all words are separated only by space. If there is other punctuation, more examples would aid in crafting an appropriate solution:
Option Explicit
Function WordRemove(Str As String, RemoveWords As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.ignorecase = True
.Global = True
.Pattern = "(?:" & Join(Split(WorksheetFunction.Trim(RemoveWords)), "|") & ")\s*"
WordRemove = .Replace(Str, "")
End With
End Function
My example is certainly not the best code, but it should work
Function WORDREMOVE(FirstCell As String, SecondCell As String)
Dim FirstArgument As Variant, SecondArgument As Variant
Dim FirstArgumentCounter As Integer, SecondArgumentCounter As Integer
Dim Checker As Boolean
WORDREMOVE = ""
FirstArgument = Split(FirstCell, " ")
SecondArgument = Split(SecondCell, " ")
For SecondArgumentCounter = 0 To UBound(SecondArgument)
Checker = False
For FirstArgumentCounter = 0 To UBound(FirstArgument)
If SecondArgument(SecondArgumentCounter) = FirstArgument(FirstArgumentCounter) Then
Checker = True
End If
Next FirstArgumentCounter
If Checker = False Then WORDREMOVE = WORDREMOVE & SecondArgument(SecondArgumentCounter) & " "
Next SecondArgumentCounter
WORDREMOVE = Left(WORDREMOVE, Len(WORDREMOVE) - 1)
End Function
Let's assume that we have one module with only one Sub in it, and there are no comments. How to identify all variable names ? Is it possible to identify names of variables which are not defined using Dim ? I would like to identify them and replace each with some random name to obfuscate my code (O0011011010100101 for example), replace part is much easier.
List of characters which could be use in names of macros, functions and variables :
ABCDEFGHIJKLMNOPQRSTUVWXYZdefghijklmnopqrstuvwxyzg€‚„…†‡‰Š‹ŚŤŽŹ‘’“”•–—™š›śťžź ˇ˘Ł¤Ą¦§¨©Ş«¬®Ż°±˛ł´µ¶·¸ąş»Ľ˝ľżŔÁÂĂÄĹĆÇČÉĘËĚÍÎĎĐŃŇÓÔŐÖ×ŘŮÚŰÜÝŢßŕáâăäĺćçčéęëěíîďđńňóôőö÷řůúűüýţ˙ÉĘËĚÍÎĎĐŃŇÓÔŐÖ×ŘŮÚŰÜÝŢßŕáâăäĺćçčéęëěíîďđńňóôőö÷řůúűüýţ˙
Below are my function I've wrote recenlty :
Function randomName(n as integer) as string
y="O"
For i = 2 To n:
If Rnd() > 0.5 Then
y = y & "0"
Else
y = y & "1"
End If
Next i
randomName=y
End Function
In goal to replace given strings in another string which represent the code of module I use below sub :
Sub substituteNames()
'count lines in "Module1" which is part of current workbook
linesCount = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule.CountOfLines
'read code from module
code = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(StartLine:=1, Count:=linesCount)
inputStr = Array("name1", "name2", "name2") 'some hardwritten array with string to replace
namesLength = 20 'length of new variables names
For i = LBound(inputStr) To UBound(inputStr)
outputString = randomName(namesLength-1)
code = Replace(code, inputStr(i), outputString)
Next i
Debug.Print code 'view code
End Sub
then we simply substitute old code with new one, but how to identify strings with names of variables ?
Edition
Using **Option Explicit ** decrease safety of my simple method of obfuscation, because to reverse changes you only have to follow Dim statements and replace ugly names with something normal. Except that to make such substitution harder, I think it's good idea to break the line in the middle of variable name :
O0O000O0OO0O0000 _
0O00000O0OO0
the simple method is also replacing some strings with chains based on chr functions chr(104)&chr(101)&chr(108)&chr(108)&chr(111) :
Sub stringIntoChrChain()
strInput = "hello"
strOutput = ""
For i = 1 To Len(strInput)
strOutput = strOutput & "chr(" & Asc(Mid(strInput, i, 1)) & ")&"
Next i
Debug.Print Mid(strOutput, 1, Len(strOutput) - 1)
End Sub
comments like below could make impression on user and make him think that he does not poses right tool to deal with macro etc.:
'(k=Äó¬)w}ż^¦ů‡ÜOyúm=ěËnóÚŽb W™ÄQó’ (—*-ĹTIäb
'R“ąNPÔKZMţ†üÍQ‡
'y6ű˛Š˛ŁŽ¬=iýQ|˛^˙ ‡ńb ¬ĂÇr'ń‡e˘źäžŇ/âéç;1qýěĂj$&E!V?¶ßšÍ´cĆ$Âű׺Ůî’ﲦŔ?TáÄu[nG¦•¸î»éüĽ˙xVPĚ.|
'ÖĚ/łó®Üă9Ę]ż/ĹÍT¶Mµę¶mÍ
'q[—qëýY~Pc©=jÍ8˘‡,Ú+ń8ŐűŻEüńWü1ďëDZ†ć}ęńwŠbŢ,>ó’Űçµ™Š_…qÝăt±+‡ĽČgřÍ!·eŠP âńđ:ŶOážű?őë®ÁšńýĎáËTbž}|Ö…ăË[®™
You can use a regular expression to find variable assignments by looking for the equals sign. You'll need to add a reference to the Microsoft VBScript Regular Expressions 5.5 and Microsoft Visual Basic for Applications Extensibility 5.3 libraries as I've used early binding.
Please be sure to back up your work and test this before using it. I could have gotten the regex wrong.
UPDATE:
I've refined the regular expressions so that it no longer catches datatypes of strongly typed constants (Const ImAConstant As String = "Oh Noes!" previously returned String). I've also added another regex to return those constants as well. The last version of the regex also mistakenly caught things like .Global = true. That was corrected. The code below should return all variable and constant names for a given code module. The regular expressions still aren't perfect, as you'll note that I was unable to stop false positives on double quotes. Also, my array handling could be done better.
Sub printVars()
Dim linesCount As Long
Dim code As String
Dim vbPrj As VBIDE.VBProject
Dim codeMod As VBIDE.CodeModule
Dim regex As VBScript_RegExp_55.RegExp
Dim m As VBScript_RegExp_55.match
Dim matches As VBScript_RegExp_55.MatchCollection
Dim i As Long
Dim j As Long
Dim isInDatatypes As Boolean
Dim isInVariables As Boolean
Dim datatypes() As String
Dim variables() As String
Set vbPrj = VBE.ActiveVBProject
Set codeMod = vbPrj.VBComponents("Module1").CodeModule
code = codeMod.Lines(1, codeMod.CountOfLines)
Set regex = New RegExp
With regex
.Global = True ' match all instances
.IgnoreCase = True
.MultiLine = True ' "code" var contains multiple lines
.Pattern = "(\sAs\s)([\w]*)(?=\s)" ' get list of datatypes we've used
' match any whole word after the word " As "
Set matches = .Execute(code)
End With
ReDim datatypes(matches.count - 1)
For i = 0 To matches.count - 1
datatypes(i) = matches(i).SubMatches(1) ' return second submatch so we don't get the word " As " in our array
Next i
With regex
.Pattern = "(\s)([^\.\s][\w]*)(?=\s\=)" ' list of variables
' begins with a space; next character is not a period (handles "with" assignments) or space; any alphanumeric character; repeat until... space
Set matches = .Execute(code)
End With
ReDim variables(matches.count - 1)
For i = 0 To matches.count - 1
isInDatatypes = False
isInVariables = False
' check to see if current match is a datatype
For j = LBound(datatypes) To UBound(datatypes)
If matches(i).SubMatches(1) = datatypes(j) Then
isInDatatypes = True
Exit For
End If
'Debug.Print matches(i).SubMatches(1)
Next j
' check to see if we already have this variable
For j = LBound(variables) To i
If matches(i).SubMatches(1) = variables(j) Then
isInVariables = True
Exit For
End If
Next j
' add to variables array
If Not isInDatatypes And Not isInVariables Then
variables(i) = matches(i).SubMatches(1)
End If
Next i
With regex
.Pattern = "(\sConst\s)(.*)(?=\sAs\s)" 'strongly typed constants
' match anything between the words " Const " and " As "
Set matches = .Execute(code)
End With
For i = 0 To matches.count - 1
'add one slot to end of array
j = UBound(variables) + 1
ReDim Preserve variables(j)
variables(j) = matches(i).SubMatches(1) ' again, return the second submatch
Next i
' print variables to immediate window
For i = LBound(variables) To UBound(variables)
If variables(i) <> "" And variables(i) <> Chr(34) Then ' for the life of me I just can't get the regex to not match doublequotes
Debug.Print variables(i)
End If
Next i
End Sub