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

Excel VBA WMI script which pulls out storage volume details for a list of servers

''' Excel vba program for accessing the storage volume details of a servers & capture the output in another csv file.


Const sPath = "F:\Files\ServerName.csv"   '''' edit the path where all the server name
Const oPath = "F:\Files\outputFile.csv"   '''' edit the path where output will be saved

Dim objWMIService, strComputer, colItems, objItem, i, lRow, rCount, wbMain, wbOutput
Dim mSht As Worksheet
Dim oSht As Worksheet

Sub Main_Mdl()

Workbooks.Open sPath
Set wbMain = ActiveWorkbook
Set mSht = wbMain.ActiveSheet
lRow = mSht.Cells(mSht.Rows.Count, 1).End(xlUp).Row

Workbooks.Open oPath
Set wbOutput = ActiveWorkbook
Set oSht = wbOutput.ActiveSheet

oSht.Cells(1, 1) = "ServerName/IP Address"
oSht.Cells(1, 2) = "BlockSize"
oSht.Cells(1, 3) = "BootVolume"
oSht.Cells(1, 4) = "Total Capacity"
oSht.Cells(1, 5) = "Free Capacity"
oSht.Cells(1, 6) = "Used Capacity"
oSht.Cells(1, 7) = "Label"
oSht.Cells(1, 8) = "Name"
oSht.Cells(1, 9) = "PageFilePresent"
oSht.Cells(1, 10) = "SupportsFileBasedCompression"

rCount = 2
For i = 2 To lRow
    strComputer = mSht.Cells(i, 1)
    Call Extract_Storage_Details
Next
wbMain.Close False

wbOutput.Save
wbOutput.Close True

End Sub

Sub Extract_Storage_Details()
On Error GoTo err462
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Volume", , 48)
For Each objItem In colItems
        oSht.Cells(rCount, 1) = strComputer
        oSht.Cells(rCount, 2) = objItem.BlockSize
        oSht.Cells(rCount, 3) = objItem.BootVolume
        oSht.Cells(rCount, 4) = Round(((objItem.capacity / 1024) / 1024) / 1024, 1)
        oSht.Cells(rCount, 5) = Round(((objItem.FreeSpace / 1024) / 1024) / 1024, 1)
        oSht.Cells(rCount, 6) = oSht.Cells(rCount, 4) - oSht.Cells(rCount, 5)
        oSht.Cells(rCount, 7) = objItem.Label
        oSht.Cells(rCount, 8) = objItem.Name
        oSht.Cells(rCount, 9) = objItem.PageFilePresent
        oSht.Cells(rCount, 10) = objItem.SupportsFileBasedCompression
        rCount = rCount + 1
Next
err462:
    If Err.Number = 462 Then
        oSht.Cells(rCount, 1) = strComputer
        oSht.Range("B" & rCount & ":J" & rCount) = "Access Denied"
        rCount = rCount + 1
        Exit Sub
    End If
End Sub

Bulk data insert into mysql using excel VBA (source format csv)

'' To use this module you first need to download the mysql ODBC 3.51 driver and install.
'' Once Installation has been done you can use the below module in your VBA code.


const sTR_ServerName ="10.2.3.311"                                         '' edit the IP address
const sTR_DbName= "dbName"                                                  '' edit the DB name
const sTR_UserID="test"                                                              '' edit the mysql user ID
const sTR_PWD="pwd"                                                                '' edit the mysql pwd 

Sub ConOpen()
'' Create ADODB Connection object
Set AdodbCon = CreateObject("Adodb.Connection")

' Open ADODB connection using the above parameters
AdodbCon.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver}" & _
";SERVER=" & sTR_ServerName & _
";DATABASE=" & sTR_DbName & _
";USER=" & sTR_UserID & _
";PASSWORD=" & sTR_PWD

'' Open adodb connection
AdodbCon.Open
End Sub

Sub Upload_To_DB(TblName)''''''''''''''''''' edit the table name

filePath="C:\Users\Desktop\Automation\Input_file\import.csv"                     '' edit the file path

'' Replacing \ slash to forward slash from the filepath
filePath = Replace(filePath, "\", "/")                 

If AdodbCon.State <> 1 Then
    MsgBox "Database connection error", vbOKOnly + vbInformation, "Connection Failed"
    Exit Sub
End If

' Importing csv file into mysql table
qRY_Sql = "LOAD DATA LOCAL INFILE '" & filePath & "' INTO TABLE " & TblName & " FIELDS TERMINATED BY ',' ENCLOSED BY '""' ESCAPED BY '' LINES TERMINATED BY '\r\n'"
AdodbCon.Execute qRY_Sql

End Sub

Excel VBA mysql database connection through mysql ODBC driver

'' To use this module you first need to download the mysql ODBC 3.51 driver and install.
'' Once Installation has been done you can use the below module in your VBA code.


const sTR_ServerName ="10.2.3.311"                                        '' edit the IP address
const sTR_DbName= "dbName" '' edit the DB name
const sTR_UserID="test" '' edit the mysql user ID
const sTR_PWD="pwd" '' edit the mysql pwd  

Sub ConOpen()
'' Create ADODB Connection object
Set AdodbCon = CreateObject("Adodb.Connection")

' Open ADODB connection using the above parameters
AdodbCon.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver}" & _
";SERVER=" & sTR_ServerName & _
";DATABASE=" & sTR_DbName & _
";USER=" & sTR_UserID & _
";PASSWORD=" & sTR_PWD

'' Open adodb connection
AdodbCon.Open
End Sub

Few important ms access VBA (DoCmd) objects

''********************** DoCmd objects in access VBA *********************************

'' This option will hide the alert messages like inserting/deleting any values in a table etc.
DoCmd.SetWarnings False

'' you can write down your sql queries but only DML queries will alloweded here"
DoCmd.RunSQL "Delete From Table_Employee"

'' By using this you can close any of the ms-access objects (like form, report, table, queries,macro, module etc.
'' change the acTable table parameter with any other above given access objects
DoCmd.Close acTable, "TableName", acSaveYes

'' By using this you can delete any of the ms-access objects (like form, report, table, queries,macro, module etc.
'' change the acTable table parameter with any other above given access objects
DoCmd.DeleteObject acTable, "TableName"

'' you can run/open any of your query object using this option (it require a Query object Name)
DoCmd.OpenQuery "QueryName"

'' By using this you can rename any of the ms-access objects (like form, report, table, queries,macro, module etc.
'' change the acTable table parameter with any other above given access objects
DoCmd.Rename "NewTableName", acTable, "OldTableName"

'' Hide ms access ribbon using Access VBA
DoCmd.ShowToolbar "Ribbob", acToolbarNo

'' Run your macros objects created in msacess
DoCmd.RunMacro "MacroName"

'' you can send your output automatically by the default email system (object Table, Query, form, Report etc.)
'' change the acSendTable table parameter and acFormatXLS as per your choice with any other above given access objects
DoCmd.SendObject acSendTable, "TableName", acFormatXLS, "abc@gmail.com", "xyz@yahoomail.com", "Test Email", "Hello"

'' Exit from msaccess
DoCmd.Quit acQuitSaveAll
Application.Quit acQuitSaveAll

Covert All the XLS file into XLSX format from the selected folder

Sub Convert_XLS_TO_XLSX()
Dim fLname As String
Dim folderPath As String
Dim fExtn As String

Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .InitialFileName = ThisWorkbook.Path & "\"
    .Title = "please select folder"
    .Show
    If .SelectedItems.Count = 0 Then
        MsgBox "folder not selected..", vbOKOnly + vbInformation, "Task Cancelled"
        Exit Sub
    Else
        folderPath = .SelectedItems(1)
    End If
End With

fLname = Dir(folderPath & "\")

While fLname <> ""
    fExtn = UCase(Right(fLname, Len(fLname) - InStrRev(fLname, ".")))
    If fExtn = "XLS" Then
        Workbooks.Open folderPath & "\" & fLname
        fLname = Left(fLname, InStrRev(fLname, ".")) & "xlsx"
        ActiveWorkbook.SaveAs folderPath & "\" & fLname, xlOpenXMLWorkbook
        ActiveWorkbook.Close True
    End If
    fLname = Dir
Wend

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "all the XLS files has been converted into XLSX format", vbOKOnly + vbInformation, "File Conversion Done"

End Sub

Import CSV file into Ms Access database and Convert into XML

'Access VBA code to import the CSV file and create a table and then export the table's data into XML File.
'' Note: Open access database -> press Alt+F11 (to open the VBA Editor) ->Insert->Module
'' Copy the below code and paste into the module
' Press F5 to run the below code
'********************************************************************************
Sub Convert_CSV_TO_XML()
    Dim fPath As String
    Dim fOutputFile As String
   
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "please select csv file"
        .Filters.Clear
        .Filters.Add "CSV Files", "*.csv"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "file not selected...", vbOKOnly + vbInformation, "Task Cancelled"
            Exit Sub
        Else
            fPath = .SelectedItems(1)
            fOutputFile = CurrentProject.Path & "\"
        End If
    End With
   
    If fPath <> vbNullString Then
        DoCmd.TransferText acImportDelim, "", "Tbl_ImportData", fPath, True
        Application.ExportXML acExportTable, "Tbl_ImportData", fOutputFile & "\output.xml", fOutputFile & "\output.xsd"
        CurrentDb.Execute "Drop table Tbl_ImportData"
        MsgBox "file created in the below folder " & Chr(13) & fOutputFile, vbOKOnly + vbInformation, "XML file has been created"
    End If
End Sub

VBA code for unzip the files (multiple files can be selected)

Option Explicit
Sub Unzip_Files()
  Dim fCounter As Integer
  Dim UzipFolderPath As String
  Dim oApp As Object

With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Zip Files", "*.zip"
    .Title = "please select zip files"
    .Show
    If .SelectedItems.Count = 0 Then
        MsgBox "file not selected", vbOKOnly + vbInformation, "Task Cancelled"
        Exit Sub
    Else
        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")
     
        UzipFolderPath = CurrentProject.Path & "\UnZippedFiles"
        MkDir UzipFolderPath
        For fCounter = 1 To .SelectedItems.Count
            oApp.Namespace(UzipFolderPath & "\").CopyHere oApp.Namespace(.SelectedItems(fCounter)).items
        Next
    End If
End With
    Set oApp = Nothing
End Sub

'************************************************************************
'check this out and let me if it works.
Note: The above code has been written in msaccess
So, if you want to run this in excel. change the above syntax:
* CurrentProject.Path to thisworkbook.path

Merge any number of CSV files into single file within a second (Vbscript)

Sub Combine_CSV_Files

Dim fLocation, sLocation, dLocation, objShell

fLocation = InputBox("please enter the folder location")

If fLocation=vbNullString then
    MsgBox "folder not selected...", vbOKOnly + vbInformation, "Task Cancelled"
    Wscript.quit
End If

sLocation = fLocation & "\*.csv"
dLocation = fLocation & "\Combined_Data.csv"

Set objShell = CreateObject("WScript.Shell")
objShell.Run "cmd /k Copy """ & sLocation & """ """ & dLocation & """ & exit", False
Set objShell = Nothing

End sub

Call Combine_CSV_Files

*********************************************************************************
Copy the above code and paste into notepad file & save the notepad file with .vbs extension.

' Then click on the saved notepad file.
' it will prompt the folder path where all the CVS files stored.
' copy the folder path and paste into the input box
' all the cvs files has been combined within a second with the file name "Combined_Data.csv

Try this very useful..!

Access VBA methods to delete ms access objects

'' Access VBA methods to delete ms access object

'************** Delete your table or query
DoCmd.RunSQL "Drop table yourTableName or yourQueryName"
CurrentDb.Execute "Drop table yourTableName or yourQueryName"


'*** Below method will allow to delete any of the access objects (Table, Query, Form, Report) *****
DoCmd.DeleteObject acQuery, "YourQueryName"

'Select any of the below access object types that you want to delete
'acTable
'acQuery
'acForm
'acReport

Access VBA Methods to export your Table, Query, Form, Report data

'Access VBA methods to export the data

'*******************You can export the data from a table , query********************

'acSpreadsheetTypeExcel12Xml for xlsx file
'acSpreadsheetTypeExcel12 for xlsb format
'acSpreadsheetTypeExcel9 for xls format

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "qRY_Final", "Destination file path"


'*****************************************************************************
'Below method will allow to export the table, form, report, query data into (Excel,txt,pdf) formats
'acFormatXLS
'acFormatTXT
'acFormatPDF
'acFormatRTF
DoCmd.OutputTo acOutputForm, "frm", acFormatTXT, "Destination file path & filename & fileextenstion"

'change the acOutput type as per your choice to select access object type
'acOutputTable
'acOutputForm
'acOutputReport
'acOutputQuery

Access VBA to Import data from Excel File

!......VBA program to Import data from Excel file & Creates a Table......!

Sub Import_From_Excel()
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "New TablenName", "Source file path"
End Sub

Internet Explorer Automation using VBScript

'''Internet Explore Automation using VBScript
'''Note:- Copy the Whole the script & paste into notepad and save the "filename.vbs"

Sub IE_Automation
Dim ie
set ie=createobject("internetexplorer.application")
ie.Visible = True
ie.AddressBar = False
ie.StatusBar = False
ie.MenuBar = False
ie.FullScreen = False
ie.Toolbar = False
ie.Navigate InputBox("Enter any url","Must Add .com/.net etc")
end sub

call IE_Automation

VBA Files Exists in the Selected Folder

!...VBA program to Display All the files in the Selected folder with name,filepath,size of file etc...!

Sub File_Names_infolder()
Dim fso As Scripting.FileSystemObject
Dim fld, fil As Object
Dim i As Integer
i = 1
Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Analyfolder"
.Show
End With
Set fld = fso.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
For Each fil In fld.Files
Cells(i, 1).Value = fil.Path
Cells(i, 2).Value = fil.Name
Cells(i, 3).Value = Left(fil.Name, Application.WorksheetFunction.Find(".", fil.Name) - 1)
Cells(i, 4).Value = Round(fil.Size / 1024)
i = i + 1
Next fil
End Sub