Fetch data from outlook in excel VBA

[Nihar Arisal]

Hi Team,

Can anybody help me for below query?.

i need to read user name and password from outlook using excel VBA.

is it possible to do this in VBA.



Thanks
Nihar Ranjan Arisal

 

[Kenneth Hobson]

Most forums have rules against showing how to crack passwords.

If you mean parse content in your inbox email, we can assist with that but not without more details. e.g. What folder, Inbox, Subject ccontent, typical body content, etc.

 

[Nihar Arisal]

Hi Kenneth,

Thanks for your quick response. Please find below details. i need to fecth user id and password from the email body.

Email Subject: Ingram Micro Australia | Welcome to our Website (stage2).

please check the attached outlook email. Let me know if any more details needed.

Thanks
Nihar

 

[Kenneth Hobson]

Sub GetInBoxFolderDetailsIfSubject()
  Dim a, u, p, i As Long, r As Range
  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim oApp As Outlook.Application, oM As Outlook.MailItem
  Dim oNS As Namespace, oG As Outlook.MAPIFolder 'Usual method.
  'Late Binding:
  'Dim oApp As Object, oM As Object, oNS As Object, oG As Object
 
  Set oApp = CreateObject("Outlook.Application")
  Set oNS = oApp.GetNamespace("MAPI")
  Set oG = oNS.GetDefaultFolder(6)  'olFolderInbox=6
  Set oM = oApp.CreateItem(0) 'olMailItem=0
 
  If oG.Items.Count = 0 Then GoTo EndSub
  ReDim a(1 To oG.Items.Count, 1 To 5)
 
  For i = 1 To oG.Items.Count
    Set oM = oG.Items(i)
    If TypeName(oM) <> "MailItem" Then GoTo NextI
      With oM
        If InStr(.Subject, "Ingram") > 0 Then
          a = Split(.Body, vbCrLf)
          u = Filter(a, "Username: ")
          p = Filter(a, "Password: ")
          If Not IsArray(u) And IsArray(p) Then GoTo NextI
          Set r = Cells(Rows.Count, "A").End(xlUp).Offset(1)
          r = Split(u(0), ": ")(1)
          r.Offset(, 1) = Split(p(0), ": ")(1)
        End If
      End With
NextI:
  Next i
 
 
EndSub:
  Set oM = Nothing
  Set oG = Nothing
  Set oNS = Nothing
  Set oApp = Nothing
End Sub