Excel VBA to send email from excel with HTML table in a email body

'' Excel vba script to send email from outlook & email body in HTML table format.
''Write down email body in HTML tags.

Sub Send_StatusDetails()

mlBody = ""
On Error Resume Next
Set OtlApp = GetObject(, "Outlook.application") 'gives error 429 if outlook is not open
If Err.Number = 429 Then
    Err.Clear
    Shell "outlook.exe", vbMaximizedFocus    ''''''''''''''''''''''' open outlook '''''''''''''
    Application.Wait Now + TimeValue("00:00:10")              ''''''''''''' wait for 10 seconds until all the emails will be loaded '''''
    Set OtlApp = GetObject("", "outlook.application")
End If
   
Set OtlMail = OtlApp.createitem(0)
With OtlMail
    .To = "your email address"
    .Subject = "summary details"
     mlBody = "<table border='1' style='font-size:12'>" & vbCrLf & "<tr><th>Table Name</th><th>Upload Date</th><th>Data Updated</th></tr>" & vbCrLf
     For i = 1 To UBound(statArr)
        If statArr(i, 1) = vbNullString Then Exit For
        mlBody = mlBody & "<tr><td>" & statArr(i, 1) & "</td><td>" & statArr(i, 2) & "</td><td>" & statArr(i, 3) & "</td></tr>" & vbCrLf
     Next
    .htmlbody = mlBody & "</table><br><br> Thanks <br>"
    .display
    .send
End With

Excel vba script to download email attachments from outlook

'' This script will download all the email attachments which is having csv files.

Option Private Module
Option Explicit

'''''''''''''''''''''''''''''''' Variable Declaration '''''''''''''''''''''''''''''
Const fPath = "C:\Users\Automation\Files\Script\"

Dim OtlApp, mlItems, aCounter, fCounter, mail, mlRcvdDT, OtlFolder, flName, AttachName
Sub Data_Download()

On Error Resume Next
Set OtlApp = GetObject(, "Outlook.application") 'gives error 429 if outlook is not open
If Err.Number = 429 Then
    Err.Clear
    Shell "outlook.exe", vbMaximizedFocus    ''''''''''''''''''''''' open outlook '''''''''''''
    Application.Wait Now + TimeValue("00:00:10")          ''''''''''''' wait for 10 seconds until all the emails will be loaded '''''
    Set OtlApp = GetObject("", "outlook.application")
End If

'' create outlook object
Set OtlFolder = OtlApp.GetNamespace("Mapi").GetDefaultFolder(6).Parent.Folders.Item("Data_Folder") '''''''''''''''''' update the desired folder name

Set mlItems = OtlFolder.Items
mlItems.Sort "ReceivedTime", True

For Each mail In mlItems
    mlRcvdDT = CDate(FormatDateTime(mail.ReceivedTime, vbShortDate))
    AttachName = "DataFile_" & Format(Date, "dd-mm-yyyy") & ".csv"  '''''''''''''''''''''''''''''''' change .csv to desired file format
    If Date = mlRcvdDT Then
        aCounter = mail.Attachments.Count
        If aCounter > 0 Then
            For fCounter = 1 To aCounter
                If InStr(1, mail.Attachments(fCounter).Filename, ".csv", vbTextCompare) > 0 Then         '''''''''''''''''''''''''''''''' change .csv to desired file format
                    mail.Attachments(fCounter).SaveAsFile fPath & flName & AttachName
                    mail.UnRead = True
                End If
            Next
        End If
    End If
Next
OtlApp.Quit
Set OtlApp = Nothing
End Sub

Excel VBA WMI script to capture the resent update patches into list of servers

'' Excel VBA script which pulls out the details of resent updated patches.

Option Explicit
Sub Check_Software_UpdateStatus()
Dim strComputer, objWMIService, colItems, objItem, mSht, oSht, I, rCount

Set mSht = ThisWorkbook.Sheets("Main")
Set oSht = ThisWorkbook.Sheets("Output")
oSht.Rows("2:65536").ClearContents

rCount = 2

For I = 2 To mSht.Cells(mSht.Rows.Count, 1).End(xlUp).Row
    strComputer = mSht.Cells(I, 1)
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_QuickFixEngineering", , 48)
        For Each objItem In colItems
            oSht.Cells(rCount, 1) = strComputer
            oSht.Cells(rCount, 2) = objItem.Caption
            oSht.Cells(rCount, 3) = objItem.CSName
            oSht.Cells(rCount, 4) = objItem.Description
            oSht.Cells(rCount, 5) = objItem.FixComments
            oSht.Cells(rCount, 6) = objItem.HotFixID
            oSht.Cells(rCount, 7) = objItem.InstallDate
            oSht.Cells(rCount, 8) = objItem.InstalledBy
            oSht.Cells(rCount, 9) = objItem.InstalledOn
            oSht.Cells(rCount, 10) = objItem.Name
            oSht.Cells(rCount, 11) = objItem.ServicePackInEffect
            oSht.Cells(rCount, 12) = objItem.Status
            rCount = rCount + 1
        Next
Next I
Set colItems = Nothing
Set objWMIService = Nothing
End Sub

Excel VBA (WMI script to restart list of servers)

' Excel vba script WMI script which restarts list of server and wait to come back & capture the what all services are running & pulls out the status & then move to next server..

Option Private Module
Option Explicit

Global i, j, strQuery, serverName, isAvailable, SystemOnline, ChkCount, objWMIService, colItems, objItem, cmd
Global rCount, lRow, mSht, oSht, OtlApp, statusWb, NewMl, emailID, wTime, arrService(), serviceName, serviceStat
Global shtRng As Range
Sub check_service_status()

With ThisWorkbook
    wTime = Trim(.Sheets("Main").Range("L6"))
    emailID = Trim(.Sheets("Main").Range("L2"))
    If wTime = vbNullString Then
         MsgBox "server wait time cannot be blank..", vbOKOnly + vbInformation, "blank server wait time"
        .Sheets("Main").Range("L6").Activate
         Exit Sub
    End If
    Set mSht = .Sheets("ServerName & ServiceName")
    Set oSht = .Sheets("Output")
    lRow = mSht.Cells(mSht.Rows.Count, 10).End(xlUp).Row
    ReDim arrService(1 To lRow, 1 To 1)
    Set shtRng = mSht.Range("J2:J" & lRow)
    arrService = shtRng
    wTime = CInt(IIf(wTime = 0, 1, wTime))
End With

'oSht.Activate
oSht.Rows("2:" & oSht.Rows.Count).ClearContents
'oSht.Range("D:D").Interior.Color = xlNone
mSht.Range("B2:C" & 1048576).ClearContents

lRow = mSht.Cells(mSht.Rows.Count, 1).End(xlUp).Row

rCount = 2

For i = 2 To lRow
    ChkCount = 1
    serverName = mSht.Cells(i, 1)
    mSht.Cells(i, 2) = Time
    Call Server_Available
    If isAvailable = True Then
                                        '''''''''''''''' send a message to restart the computer and wait for a 60 seconds
        cmd = Shell("SHUTDOWN /r /f /t 60 /m \\" & serverName & " /c " & """The computer will restart in next 60 seconds, please save all work.""", vbHide) '''''''''''''''''' command to restart the remote machine ''''''''''''
        Application.Wait Now + TimeValue("00:00:10")
        Call Server_Available
        If isAvailable = True Then
            Call Capture_Service_Status
        End If
    End If
    mSht.Cells(i, 3) = Time
Next

If emailID <> vbNullString Then Call Send_StatusReport
ThisWorkbook.Save
End Sub
Sub Server_Available()

isAvailable = False

' Define the WMI query
strQuery = "SELECT * FROM Win32_PingStatus WHERE Address = '" & serverName & "'"

' Run the WMI query
Set colItems = GetObject("winmgmts://./root/cimv2").ExecQuery(strQuery)

' WMI query result loop
For Each objItem In colItems
    If Not IsObject(objItem) Then
        SystemOnline = False
    ElseIf objItem.StatusCode = 0 Then
        isAvailable = True
    Else
        isAvailable = False
    End If
Next
''''''''''''''''''''''''''''''' check whether the server is available for ping/login
If isAvailable = False And ChkCount <= ((wTime * 60) / 30) Then
    ChkCount = ChkCount + 1
    Application.Wait Now + TimeValue("00:00:30")
    Call Server_Available
ElseIf ChkCount > ((wTime * 60) / 30) Then        ''''''''''''''''''''''''''''''''''''''' if server not available after 600 seconds then update the sheet
    oSht.Cells(rCount, 1) = serverName
    oSht.Cells(rCount, 2) = "No"
    oSht.Cells(rCount, 3) = "Permission denied"
    oSht.Cells(rCount, 4) = "Permission denied"
    'oSht.Cells(rCount, 4).Interior.ColorIndex = 15
    rCount = rCount + 1
End If
End Sub
Sub Capture_Service_Status()

For j = 1 To UBound(arrService)
    Set objWMIService = GetObject("winmgmts:\\" & serverName & "\root\CIMV2")
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Service", , 48)
    serviceName = vbNullString
    serviceStat = vbNullString
    For Each objItem In colItems
        If UCase(Trim(objItem.Name)) = UCase(Trim(arrService(j, 1))) Then
            serviceName = objItem.Name
            serviceStat = objItem.State
            Exit For
        End If
    Next
        oSht.Cells(rCount, 1) = serverName
        oSht.Cells(rCount, 2) = "Yes"
        oSht.Cells(rCount, 3) = arrService(j, 1)
        oSht.Cells(rCount, 4) = IIf(serviceStat <> vbNullString, serviceStat, "Service not exists")
        'If LCase(serviceStat) = "running" Then
            'oSht.Cells(rCount, 4).Interior.ColorIndex = 43
        'Else
            'oSht.Cells(rCount, 4).Interior.ColorIndex = 3
        'End If
        rCount = rCount + 1
        Set objItem = Nothing
        Set colItems = Nothing
        Set objWMIService = Nothing
Next j
End Sub
Sub Send_StatusReport()

    On Error Resume Next
    Set OtlApp = GetObject(, "outlook.application")

    If Err.Number = 429 Then
        Err.Clear
        Shell "outlook.exe", vbMaximizedFocus
        Set OtlApp = GetObject("", "outlook.application")
    End If

    oSht.Copy
    Set statusWb = ActiveWorkbook
    statusWb.SaveAs ThisWorkbook.Path & "\Service_StatusReport.xlsb", xlExcel12
    statusWb.Close True

    Set NewMl = OtlApp.createitem(0)
    With NewMl
        .To = emailID
        .Subject = "Service Status Report"
        .body = "Please find attached Service Status Report"
        .Attachments.Add ThisWorkbook.Path & "\Service_StatusReport.xlsb"
        .display
        .send
    End With

Application.Wait Now + TimeValue("00:00:10")

Set statusWb = Nothing
Set NewMl = Nothing
OtlApp.Quit
Set OtlApp = Nothing

'' delete the stauts file after send
Kill ThisWorkbook.Path & "\Service_StatusReport.csv"
End Sub

About Me

I am Vikas Rawat, author of this blog site,
http://learn-excelaccessvba.blogspot.in/, is an online webpage for learning Excel/Access/VBA.

When I started to use excel , I never know that Excel is that much effective tool. I learn Excel through Internet , Experiments , Books etc. I thought one day why not share this knowledge.Lot persons are asking me secrets of excel , freelancing , part time income. So instead telling same things to different persons I thought we can share this things via this blog site.

Microsoft Excel has been my passion for a long time, I use VBA programming extensively to get enhanced functionality beyond an Excel spreadsheet, and use automation in Excel to integrate with other Office Applications like PowerPoint, Word & Outlook, and to connect with databases like Microsoft Access.

I have strived to create a site to make learning VBA simple and quick, realizing how at the beginning you might find VBA to be challenging, and the elementary questions you might be scared of asking.

I will be interested to know if you find this blog useful. You are welcome to report any errors or any suggestion for improvement. I will earnestly consider all your valuable inputs. Thanks in advance for your valuable time!

excel vba script to capture the user names who ever logged in a list of servers (infrastructure management)

'' Excel vba script which connects to a server and get the usernames who's ever logged into this machine

Option Private Module
Option Explicit

Public fso As New Scripting.FileSystemObject
Public fl As Folder
Public subFl As Folders
Public fPath As String
Public sCount As Long
Public mSht As Worksheet
Public rSht As Worksheet
Public lRow As Long
Public i As Long

Sub check_LoginDetails()

Set mSht = ThisWorkbook.Sheets("Sever_IPAddress")
Set rSht = ThisWorkbook.Sheets("Result")

sCount = 2
lRow = mSht.Range("A1048576").End(xlUp).Row
rSht.Rows("2:1048576").ClearContents

For i = 2 To lRow
    Call Return_UserName(mSht.Cells(i, 1))
Next
rSht.Activate

Set fso = Nothing
Set mSht = Nothing
Set rSht = Nothing

MsgBox "done"
End Sub

Sub Return_UserName(strComputer As String)
    On Error GoTo err1
 
    fPath = "\\" & strComputer & "\c$\users\"

    Set fl = fso.GetFolder(fPath)
    Set subFl = fl.SubFolders
 
    For Each fl In subFl
        rSht.Cells(sCount, 1) = strComputer
        rSht.Cells(sCount, 2) = fl.Name
        rSht.Cells(sCount, 3) = fl.DateLastModified
        rSht.Cells(sCount, 4) = fl.DateLastAccessed
        sCount = sCount + 1
    Next
 
err1:
If Err.Number <> 0 Then
    rSht.Cells(sCount, 1) = strComputer
    rSht.Cells(sCount, 2) = "No Data"
    sCount = sCount + 1
End If
End Sub

Excel vba code to execute Unix/Linux commands from windows machine via plink

'' Excel vba code to execute any of the unix/linux commands from windows environment via plink & capture the output in a csv file.

'' To use this module you need to download the plink.exe file from google & then execute the below script.

Global uName, Pwd, cmdTxt, cmd, sName
Global pLink, OutfPath, ScriptPath, wshShell, oExec, sRow, sCol, i

Sub Execute_UnixScript()
 
    pLink = "C:\Users\desktop\plink.exe"                                        '' edit the plink file path
    'ScriptPath = "C:\Users\desktop\script.sh"                                 '' edit the script file path
    OutfPath = "C:\Users\desktop\cmdOut.csv"                               '' edit the output file path
 
    Kill OutfPath
 
    Application.SheetsInNewWorkbook = 1
    Workbooks.Add
    ActiveWorkbook.SaveAs OutfPath, xlCSV
 
    sName = "1.1.12.13"                                                     '' edit the unix server name
    uName = "username"                                                   '' edit the user name 
    Pwd = "pwd"                                           '' edit the password
 
    If pLink = "" Or OutfPath = "" Or ScriptPath = "" Then Exit Sub

    'cmd = Chr(34) & pLink & Chr(34) & " -t -ssh " & uName & "@" & sName & " -pw " & Pwd & " -m " & Chr(34) & ScriptPath & Chr(34) ''' use this if you want to execute a unix/linux script file

     cmd = Chr(34) & pLink & Chr(34) & " -t -ssh " & uName & "@" & sName & " -pw " & Pwd & " sudo pvs -o pv_name,pv_size,pv_free --separator , --noheading"
     
    '' shell object created for executing the command
    Set wshShell = CreateObject("WScript.Shell")
 
    '' command has been executed
    Set oExec = wshShell.Exec(cmd)
         
    sRow = 2
    sCol = 2

    With Workbooks("cmdout.csv").ActiveSheet
        .Cells(1, 1) = "Server IP"
        .Cells(1, 2) = "PV"
        .Cells(1, 3) = "PSize"
        .Cells(1, 4) = "PFree"
        .Cells(1, 5) = "Date"

        ''' Read all command output line by line
        While Not oExec.StdOut.AtEndOfStream
            cmdTxt = Split(oExec.StdOut.ReadLine, ",")
            .Cells(sRow, 1) = sName
                For i = 0 To UBound(cmdTxt)
                    .Cells(sRow, sCol) = Trim(cmdTxt(i))
                    sCol = sCol + 1
                Next
            .Cells(sRow, 5) = Format(Date, "yyyy-mm-dd")
            sCol = 2
            sRow = sRow + 1
        Wend
    End With
    Workbooks("cmdout.csv").Close True
 
    Set wshShell = Nothing
    Set oExec = Nothing
End Sub