Wednesday, December 27, 2017

Automating searching mails in outlook with a particular word in the subject,copy the mail message and the sender's mail address in an existing excel file,VBA Teacher Sourav,Kolkata 09748184075


Sub CloseOutlook()
Dim OL As Object
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
On Error GoTo 0
If OL Is Nothing Then
'MsgBox "Outlook is not running!"
Else
OL.Quit
End If
End Sub


 Sub Search_Inbox()
 'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Dim wb As Workbook
 'Trying to close outlook first

 CloseOutlook
 'Trying to close the target excel file

    'now let's see if the workbook where the data to be pasted is open or not
       
         Dim status As Boolean

         status = IsWorkBookOpen("C:\Users\sourav\Desktop\data.xlsm")
         If status = True Then
         Workbooks("data.xlsm").Close SaveChanges:=True
        
         End If
       

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Dim Found As Boolean
Dim atmt As Outlook.Attachment
Dim MyAr() As String
Dim address As String
Dim message As String


Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
On Error Resume Next

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False

For Each myItem In myitems
    If myItem.Class = olMail Then
        If InStr(1, myItem.Subject, "macro") > 0 Then
            'MsgBox ("Found")
            For Each atmt In myItem.Attachments

                If atmt.FileName = "macro.txt" Then
                    atmt.SaveAsFile "D:\" & atmt.FileName
                    'MsgBox (myItem.SenderEmailAddress)
                    'saving the mail body in an array
               
                    MyAr = Split(myItem.Body, vbCrLf)

                    For i = LBound(MyAr) To UBound(MyAr)
                        '~~> This will give you the contents of your email
                        '~~> on separate lines
                        'MsgBox (MyAr(i))
                        If MyAr(i) <> "" Then
                        message = message + MyAr(i)
                        End If
   
   
                    Next i

                    'Now trying to write the message and the sender address in an existing excel file

                    'First trying to close the file if it is already open
                    On Error Resume Next

                    Workbooks("data.xlsm").Close SaveChanges:=True

                    'now trying to open the file

                    Set wb = Workbooks.Open("C:\Users\sourav\Desktop\data.xlsm")
                    'now finding the spicific column with some word or words
                    Set ws = wb.Sheets("Sheet2")

                    With ws
                        Set aCell = .Range("A1:P1").Find(What:="Mail*", LookIn:=xlValues, LookAt:=xlWhole, _
                        MatchCase:=False, SearchFormat:=False)
                        If Not aCell Is Nothing Then
                            col = aCell.Column
                            colName = Split(.Cells(, col).address, "$")(1)
                            'MsgBox (colName)

                            lRow = .Range(colName & .Rows.count).End(xlUp).Row
                            'MsgBox (lRow)
           
                            '~~> This is your range
                            'Set Rng = .Range(colName & "8:" & colName & lRow)

                            'MsgBox (Rng.address)
                            '~~> If not found
       
                            'Now find the blank cell in the column found earlier
                            Set Rng = .Range(colName & lRow)
                            Rng.Select
       
                             Range(Selection.End(xlDown)).Select
                             ActiveCell.Offset(1, 0).Select
                            
                           
                            ActiveCell.Value = myItem.SenderEmailAddress
                            If ActiveCell.Offset(0, 1) = "" Then
                                ActiveCell.Offset(0, 1).Value = message
                            End If
                            ws.Columns.AutoFit
                        Else
                            ' MsgBox "Mail Not Found"
                        End If
                        End With
                        On Error Resume Next
                        wb.Close SaveChanges:=True
                        Set wb = Nothing
                        Set ws = Nothing
                       
                        'MsgBox ("Done")

                End If


                message = ""
            Next
                Found = True
        End If
    End If
Next myItem

'If the subject isn't found:
If Not Found Then
   ' NoResults.Show
   MsgBox ("Task Failed")
  
End If

myOlApp.Quit
Set myOlApp = Nothing


'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Monday, December 25, 2017

Search mail in outlook with a particular word in the subject and read the message in the mail line by lines using VBA,VBA Teacher Sourav,Kolkata 09748184075


Sub CloseOutlook()
Dim OL As Object
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
On Error GoTo 0
If OL Is Nothing Then
MsgBox "Outlook is not running!"
Else
OL.Quit
End If
End Sub


 Sub Search_Inbox()
 'Trying to close outlook first

 CloseOutlook


Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Dim Found As Boolean
Dim atmt As Outlook.Attachment
Dim MyAr() As String
On Error Resume Next

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myitems = myInbox.Items
Found = False

For Each myItem In myitems
    If myItem.Class = olMail Then
        If InStr(1, myItem.Subject, "macro") > 0 Then
            'MsgBox ("Found")
            For Each atmt In myItem.Attachments

If atmt.FileName = "macro.txt" Then
atmt.SaveAsFile "D:\" & atmt.FileName

MyAr = Split(myItem.Body, vbCrLf)

For i = LBound(MyAr) To UBound(MyAr)
    '~~> This will give you the contents of your email
    '~~> on separate lines
    MsgBox (MyAr(i))
Next i
MsgBox ("Done")

End If



Next
            Found = True
        End If
    End If
Next myItem

'If the subject isn't found:
If Not Found Then
   ' NoResults.Show
End If

myOlApp.Quit
Set myOlApp = Nothing

End Sub

Saturday, December 23, 2017

find mail based on words in subject in outlook and save their attachments,VBA Teacher Sourav,Kolkata 09748184075

Sub Search_Inbox()

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim atmt As Outlook.Attachment
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False

For Each myitem In myitems
    If myitem.Class = olMail Then
        If InStr(1, myitem.Subject, "macro") > 0 Then
            'MsgBox ("Found")
            For Each atmt In myitem.Attachments

If atmt.Filename = "macro.txt" Then
atmt.SaveAsFile "F:\" & atmt.Filename
End If



Next
            Found = True
        End If
    End If
Next myitem

'If the subject isn't found:
If Not Found Then
    NoResults.Show
End If

myOlApp.Quit
Set myOlApp = Nothing

End Sub


Source:Stackoverflow

Friday, December 22, 2017

Open a workbook in a directory,filter the data based on criteria,copy the filtered data in a different workbook,automating daily office work using VBA,VBA teacher Sourav,Kolkata 09748184075

Option Explicit




Sub LoopAllExcelFilesInFolder()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim N As Long
'First trying to close the file if it is already open
On Error Resume Next

Workbooks("data.xlsm").Close SaveChanges:=True

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "data.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(FileName:=myPath & myFile)
   
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
   
    'Change First Worksheet's Background Fill Blue
      wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
     
      'Let's try the autofiltering
        ActiveWorkbook.Sheets("Sheet1").Activate
     
      
        On Error Resume Next
   
        ActiveWorkbook.ActiveSheet.ShowAllData
  
        ActiveSheet.Range("A1").AutoFilter Field:=35, Criteria1:= _
        "August 2015"
       
       
     
        N = Range("AI" & Rows.count).End(xlUp).Row
        Range("AI2:AI" & N).Select
        Selection.Copy
    'Save and Close Workbook
      wb.Close SaveChanges:=True
     
        'now let's see if the workbook where the filtered data to be pasted is open or not
       
         Dim status As Boolean

         status = IsWorkBookOpen("C:\Users\sourav\Desktop\filter_final_RD.xlsx")
         If status = False Then

         Workbooks("C:\Users\sourav\Desktop\filter_final_RD.xlsx").Open
         End If
        
         Workbooks("C:\Users\sourav\Desktop\filter_final_RD.xlsx").Activate
         ActiveWorkbook.Sheets("DATABASE").Select
         Range("AJ3").Select
         ActiveSheet.Paste
        
       
         Application.CutCopyMode = False
         wb.Activate
        
        

     
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Let/'s try the filtering

'Message Box when tasks are completed
  MsgBox "Task Complete!"

 Workbooks("C:\Users\sourav\Desktop\filter_final_RD.xlsx").Activate
         ActiveWorkbook.Sheets("DATABASE").Select
ActiveWorkbook.Save

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True



End Sub

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function