Excel 2010 VBA email extractor source code

Sub pickmail() 'http://emailx.discoveryvip.com/
Dim i, j, l, c As Long
Dim a, b As Long
Dim s As String
Const max = 10000
Dim ss() As String
Dim coll As String
l = 0
coll = "Email Address:"
For i = 1 To max
If CStr(ws(i, 1)) <> "" And Len(CStr(ws(i, 1))) > 10 And _
InStr(1, CStr(ws(i, 1)), "@") > 2 Then
s = CStr(ws(i, 1))
s = "a " & s
s = Replace(s, "me at", " ")
s = Replace(s, "Email at", " ")
s = Replace(s, "(", " ")
s = Replace(s, """", " ")
s = Replace(s, "/", " ")
s = Replace(s, "...@", "???@")
s = Replace(s, "...", " ")
s = Replace(s, ")", " ")
s = Replace(s, ",", " ")
s = Replace(s, ";", " ")
s = Replace(s, "=", " ")
s = Replace(s, "[at]", "@")
s = Replace(s, "[.]", ".")
's = Replace(s, " at ", "@")
s = Replace(s, "-at-", "@")
s = Replace(s, "(at)", "@")
s = Replace(s, "<at>", "@")
s = Replace(s, " @ ", "@")
s = Replace(s, "<", " ")
s = Replace(s, ">", " ")
s = Replace(s, "|", " ")
s = Replace(s, ".htm", " ")
s = Replace(s, ".html", " ")
s = Replace(s, "gmail.com", "gmail.com ")

ss = Split(s, " ")
    For j = 1 To UBound(ss)
    If InStr(ss(j), "@") > 0 And InStr(ss(j), ".") And Not Mid$(ss(j), 1, 1) = "." And _
    Not InStr(1, ss(j), "*") > 0 Then
       
        If InStr(1, coll, ss(j)) < 1 Then
        c = c + 1
             
        If Mid$(StrReverse(ss(j)), 1, 1) = "." Then
        w c, 8, StrReverse(Mid$(StrReverse(ss(j)), 2))
        coll = coll & StrReverse(Mid$(StrReverse(ss(j)), 2)) & ","
        Else
        w c, 8, ss(j)
        coll = coll & ss(j) & ","
        End If
        End If
    End If
    Next j
End If
Next i

MsgBox "c= " & c & vbCrLf & coll
End Sub

Sub alias()
Dim i As Long
Dim s As String
For i = 1 To 2000
If Len(CStr(Worksheets(1).Cells(i, 1).Value)) > 7 Then
s = CStr(Worksheets(1).Cells(i, 1).Value)
    k = InStr(1, s, "@")
   
    If k > 0 Then
    j = j + 1
    Cells(j, 9).Value = Mid$(s, k - 6, 16)
   
    End If

End If
Next
End Sub

Sub www()
'On Error Resume Next
Dim i, j, k, l, m As Long
Dim s As String
For i = 1 To 2000
'If Worksheets(1).Cells(i, 1).Value <> "" Then
If Len(CStr(Worksheets(1).Cells(i, 1).Value)) > 7 Then
s = CStr(Worksheets(1).Cells(i, 1).Value)
    k = InStr(1, s, "www.")
   
    If k > 0 Then
    l = InStr(2, s, "/")
    If l > 0 And l > k Then
    j = j + 1
    Cells(j, 10).Value = Mid$(s, k, l - k)
    End If
    End If

End If
Next i
End Sub
Sub typedrama()
Dim i As Long
Dim s  As String
For i = 1 To 67
If i < 10 Then
s = "type drama0" & i & ".txt >> dra.txt"
w i, 8, s
Else
s = "type drama" & i & ".txt >> dra.txt"
w i, 8, s
End If
Next
End Sub
Sub types()
Dim i As Long
Dim s  As String
For i = 1 To 67
If i < 10 Then
s = "type movies0" & i & ".txt >> mov.txt"
w i, 8, s
Else
s = "type movies" & i & ".txt >> mov.txt"
w i, 8, s
End If
Next
End Sub
Sub array_make()
Dim i, j As Long
Dim s, t As String
j = 0
For i = 1 To 39677
s = ws(i, 1)
If InStr(1, s, "\") > 2 Or InStr(1, s, "bytes") > 2 Or Len(s) < 5 Or _
InStr(1, s, "Volume") > 0 Or InStr(1, s, "files") > 1 Then
Else
j = j + 1
t = "sl(" & j & ") = " & """" & s & """"
w j, 8, t
End If
Next
MsgBox j

End Sub

Sub Genmail()
Dim i, j, k, tot As Integer
Dim l As Integer

Dim s As String
l = 0
tot = 0
For i = 1 To 22
For j = 1 To 18
If Len(ws(j, 5) & ws(i, 1)) > 6 Then
s = s & ws(j, 5) & ws(i, 1) & "@gmail.com,"
tot = tot + 1
End If
Next 'j
l = l + 1
w l, 7, s
s = ""
Next

w 1, 6, CStr(tot)
End Sub
Sub w(i As Long, j As Long, k As String)
'ÊÇ°ÑÏÂÃæµÄ´úÂë¼ò»¯£¬cells£¨column£¬row£©
Worksheets(1).Cells(i, j).Value = k
End Sub
Function ws(i, j)
'ÓÃÀ´¶Á¸ñ×ÓµÄvalue
ws = Worksheets(1).Cells(i, j).Value
End Function

Sub ll()
If InStr(1, ws(i, 1), "@") Then
s = Mid$(ws(i, 1), InStr(1, ws(i, 1), "@") - 10, 29)
l = l + 1
w l, 10, s
End If
End Sub