Send an email through outlook including excel graphs/charts

Sub CopyAllChartsToOutlookEmail()
    
     Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xStartMsg As String
    Dim xEndMsg As String
    Dim xChartName As String
    Dim xChartName1 As String
    Dim xChartPath As String
    Dim xChartPath1 As String
    Dim xPath As String
    Dim xPath1 As String
    Dim xChart As ChartObject
    Dim xChart1 As ChartObject
    
    ''----------Copying chart----
    
    On Error Resume Next
    xChartName = "Chart 2"
    xChartName1 = "Chart 3"
    If xChartName = "" And xChartName1 = "" Then Exit Sub
    Set xChart = Sheets("Dashboard").ChartObjects(xChartName)
    Set xChart1 = Sheets("Dashboard").ChartObjects(xChartName1)
    
    
    xChart.Height = 190
    xChart.Width = 200
    
    xChart1.Height = 180
    xChart1.Width = 190
    
    Dim msgdate1 As String
    Dim msgdate2 As String
    Dim msgdate3 As String
    Dim msgdate4 As String
    
    Dim msgdate5 As String

    
'    MsgBox (xChart1)
    If xChart Is Nothing Then Exit Sub
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xStartMsg = "<font size='3' color='black'>" & dt1 & " | " & Format(dt, "yyyy") & "</font>" & "<font size='5'><br><b>" & "Balance Sheet Account Reconciliation Status " & "</b><br><br></font>"
    xEndMsg = "<font size='4' color='black'><b> Reconciliation Due Dates" & "</b><br></font>"
    
'    msgdate1 = "<font size='3'><b><br>" & "High risk accounts" & "</b></font>" & "<font size='2' color='black'>" & "<ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review  - " & RevDate1 & "</li></ul></font>"
'    msgdate2 = "<font size='3'><b>" & "Medium risk accounts " & "</b></font>" & "<font size='2' color='black'>" & "<ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review  - " & RevDate1 & "</li></ul></font>"
'    msgdate3 = "<font size='3'><b>" & "Low risk accounts" & "</b></font>" & "<font size='2' color='black'>" & "<ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review  - " & RevDate1 & "</li></ul></font>"
    
    msgdate4 = "<font size='5'><b>" & "Reconciliation Completeness | High Risk Accounts " & "</b><br></font>"

    msgdate5 = "<font size='3'><ul><li><b>High risk accounts</b></li><ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review - " & RevDate1 & "</li></ul><li><b>Medium risk accounts</b><ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review - " & recDate1 & "</li></ul></li><li><b>Low risk accounts</b><ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review - " & recDate1 & "</li></ul></li></ul></font>"
    
    xChartPath = ThisWorkbook.Path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".jpg"
    Application.Wait (Now() + TimeValue("00:00:01"))
    xChartPath1 = ThisWorkbook.Path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".jpg"
    xPath = "<p align='Left'><img src=" / "cid:" & Mid(xChartPath, InStrRev(xChartPath, "\") + 1) & """  width=100 height=100 > <br> <br>"
    xPath1 = "<p align='Left'><img src=" / "cid:" & Mid(xChartPath1, InStrRev(xChartPath1, "\") + 1) & """  width=100 height=100 > <br> <br>"
    xChart.Chart.Export xChartPath
    xChart1.Chart.Export xChartPath1
       
    With xOutMail
        .To = "abc@123.com"
        .Subject = "High risk accounts reconciliation | Status " & dt1
        .Attachments.Add Environ("USERPROFILE") & "\Documents\TrinTech_Auto\Detailed Performance PG all units- high risk_not_Completed.xlsx"
        .HTMLBody = xStartMsg & xEndMsg & msgdate5 & msgdate4 & "<img src=" & "'" & xChartPath & "'>" & "<img src=" & "'" & xChartPath1 & "'></html>"
        .Display
'        .Send
    End With
    Kill xChartPath
    Kill xChartPath1
    Set xOutMail = Nothing
    Set xOutApp = Nothing

'     MsgBox ("File is attached and created the email Body with the Dashboard")
    
End Sub

How to open an excel sheet through a MS Access Button and do it modification.

Dim db As DAO.Database
Set db = CurrentDb()
      
Dim FileNameBase As String
FileNameBase = CurrentProject.path & "\YourExcelSheetName ".xlsx"
Dim strFileName As String
strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

'---Exporting from Ms Access table to an Excel worksheet
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "TableName1", strFileName, True, "Sheet_One_Name_You_Want"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "TableName2", strFileName, True, "Sheet_Two_Name_You_Want"

'--------------Open that excel sheet and here you do all modification-----------------------------------
 Dim appExcel1 As Excel.Application
    Dim wbk1 As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    
    Set appExcel1 = Excel.Application
    appExcel1.Visible = True
    Set wbk1 = appExcel1.Workbooks.Open(strFileName)
    
    appExcel1.ScreenUpdating = False
 ' -----------------------------------Formatting Sheet_One_Name_You_Want Sheet -------------------
     Sheets("Sheet_One_Name_You_Want").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Columns.AutoFit
    Range(Selection, Selection.End(xlToRight)).Columns.AutoFit
    Range(Selection, Selection.End(xlDown)).HorizontalAlignment = xlLeft
    Range(Selection, Selection.End(xlToRight)).HorizontalAlignment = xlLeft

    Range("A1:AK1").RowHeight = 30
    Range("A1:AK1").ColumnWidth = 15
    Range("A1:AK1").Font.Bold = True
    Range("A1:AK1").WrapText = True
    Range("A1:AK1").VerticalAlignment = Excel.Constants.xlCenter

'---------------Coloring-----------------
Range("A1:B1").Select
Selection.Interior.ColorIndex = 33

Range("C1").Select
Selection.Interior.ColorIndex = 27
Range("D1").Select
Selection.Interior.ColorIndex = 45

'--------------Change Data type to Currency Format for a Particular column--------------
Range("F2:F100").Select
Selection.Style = "Currency"
'------------------FreezePanes for a Particular column--------------
Range("C1").Select
wbk1.Application.ActiveWindow.FreezePanes = True
END Sub

Border Line for a filled cell in Excel VBA.

Once a time I was trying to create a report on excel through MS ACCESS vba. At that time I was really wanted to keep the border for all filled cells. I got a user define function from a browsing web page and it was really helpful.  You can modify this function according to your requirement.

Sub TheBorderLine()

With ActiveSheet.UsedRange.Borders

        .LineStyle =xlContinuous

        .Weight = xlThin

        .ColorIndex = xlAutomatic

 End With

    With ActiveSheet

        .Cells.Font.Size ="10"  

ActiveSheet.Cells.HorizontalAlignment = xlLeft

          End With

        Range("A1:S1").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

  End Sub

Execution Process :
Call this function inside your button just like a - call TheBorderLine or just put TheBorderLine.
Make sure that your workbook is open while calling this function.

Rename a Table Under a MS Access File

Edit Table Name in MS Access (.accdb or .mdb format) through a click button.

Dim tdf As TableDef
    Set db = DBEngine.Workspaces(0).OpenDatabase("InputPath")
    Set tdf = db.TABLEDEFS("TableName")
    tdf.Name = "TableName" + "_SomeThing_NEW"

Export Query Result to an Existing Excel Sheet in MS Access

The below function will export your all data from MS Access Query result to an existing Excel sheet.

Public Function SendTQ2XLWbSheet2(strTQName As String, strSheetName As String, strFilePath As String)
 Dim db As DAO.Database
 Set db = CurrentDb()
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Dim strPath As String
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler
    strPath = strFilePath
     Set rst = CurrentDb.OpenRecordset(strTQName)
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Open(strPath)
    ApXL.Visible = True
     Set xlWSh = xlWBk.Worksheets(strSheetName)
     xlWSh.Activate

 'formatting Excel tab
 '======A1 row formatting======='
    xlWSh.Range("A1").Value = "Heading_Name" 
    xlWSh.Range("A1").Interior.Color = RGB(255, 228, 196)
    xlWSh.Range("A1").Columns.Font.Bold = True
    xlWSh.Range("A1").Font.Size = 14
    xlWSh.Range("A1").HorizontalAlignment = xlCenter
    '====Table Header moving and fomatting========'
    xlWSh.Range("A2:S2").Select
    xlWSh.Range("A2:S2").Interior.Color = RGB(169, 169, 169)
    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next
    rst.MoveFirst
    xlWSh.Range("A3").CopyFromRecordset rst
' =====Data will pasted from A3 row ======='
     rst.Close
     Set rst = Nothing
     xlWBk.Close True
    Set xlWBk = Nothing
    ApXL.Quit
    Set ApXL = Nothing
Exit_SendTQ2XLWbSheet4:
    Exit Function
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_SendTQ2XLWbSheet4
   End Function

Execution Process

Private Sub Command5_Click()
Dim db As DAO.Database
Set db = CurrentDb()
Dim path As String
path = CurrentProject.path
Dim fName As String
fName = "23 MHS_Q1-Q2-Q3-Q4 Status_12Jun17-QuarterlyReport.xlsx" (excel file name)
Dim p As String
p = path & "\" & fName
If SendTQ2XLWbSheet2("Query_Name", "Tab_Name(in Excel)", p ) = True Then
End If
MsgBox "Excel Report Created...!!!"
End Sub

Drop Existing table in MS Access :

I have posted an another option to drop an existing table in MS Access. Through VBA function we can drop an existing table Drop Existing table in MS Access (VBA). Here an alternate way we can do the same operation through a small code in VBA.

Dim Tbl As TableDef      
Dim TABLEDEFS
    For Each Tbl In db.TABLEDEFS
    If Tbl.Name = "DUP" Then
    db.Execute "DROP TABLE [DUP]"
    End If
Next Tbl

Use of Sub datasheet in MS Access

When two tables have one or more fields in common, you can embed the datasheet from one table in another. An embedded datasheet, which is called a subdatasheet, is useful when you want to view and edit related or joined data in a table or query.

On above scenario Table1 and Table2 has a common values in ID column. To fetch respective Address from Table2 where ID is matching with Table1.
Follow the below steps one by one.

Select table name and common column name

Click ok

Note : If values are not matching it will show null values.

Drop Column if Exists in MS Access

Function ifFieldExists(ByVal fieldName As String, ByVal TableName As String) As Boolean
Dim db As DAO.Database
    Dim tbl As TableDef
    Dim fld As Field
    Dim strName As String
    Set db = CurrentDb
    Set tbl = db.TableDefs(TableName)
    For Each fld In tbl.Fields
        If fld.Name = fieldName Then
            ifFieldExists = True
            Exit For
        End If
    Next
End Function
Execution Process:
paste this code under a button
If ifFieldExists("Column_Name", "Table_Name") Then
db.execute "Alter table Table_Name drop column Column_Name"
Else
db.Execute "Alter table Table_Name add column Column_Name text"

End If

Drop table if Exist in MS Access

Public Function ifTableExists(TableName As String) As Boolean
Dim rs As Recordset 'Sub DAO Vars
On Error GoTo fs
'This checks if a Table is there and reports True or False.
Set db = CurrentDb()
'If Table is there open it
Set rs = db.OpenRecordset("Select * from " & TableName & ";")
ifTableExists = True
rs.Close
db.Close
Exit Function
fs:
'If table is not there close out and set function to false
Set rs = Nothing
db.Close
Set db = Nothing
     ifTableExists = False
  Exit Function
End Function
Execution Process:
paste this code under a button
If ifTableExists("Table_name") Then
db.Execute "Drop table Table_Name"
End If

Export Table from MS Access to SQL Server and Execute Store Procedure

Private Sub Command2_Click()
Dim db As DAO.Database
Set db = CurrentDb
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
'==========Execute Store Procedure with parameter passing===============
Dim P
P = InputBox("Please Enter Table Name")
cnn.ConnectionString = "Provider=SQLOLEDB;Data Source=SEREVER_NAME;Database=DB_Name;UID=USER_ID;PWD=USER_Passowrd"
cnn.Open
Set rs = New ADODB.Recordset
Set rs = cnn.Execute("EXEC [Process_Normalisation] " & P & " ")
Set rs = Nothing
cnn.Close
MsgBox "Sp Execution Successfully Done !!!"
'================export table to the server===========================
DoCmd.TransferDatabase _
  acExport, _
  "ODBC Database", _
  "ODBC;Driver={SQL Server};Server=SEREVER_NAME;Database=DB_Name;UID=USER_ID;PWD=USER_Passowrd;", _
  acTable, _
  "Import_process", _
  "Process"    
  MsgBox "File Exported to the server !!!"
END SUB

Import Access file through button in VBA MS Access

Private Sub Command2_Click()
Dim db As DAO.Database
Set db = CurrentDb
Const msoFileDialogFilePicker As Long = 3
Dim objDialog As Object
Set objDialog = Application.FileDialog(msoFileDialogFilePicker)
With objDialog
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count = 0 Then
        MsgBox "!! No file selected.Please Select One !!"        
    Else
    For Each vrtSelectedItem In .SelectedItems
                FileName = vrtSelectedItem
               DoCmd.TransferDatabase acImport, "Microsoft Access", FileName, acTable, "Process", "Import_process", False
            Next
    End If
End With
END SUB

Select any particular Alphanumeric values from a column in MS Access:

From above scenario , i am just fetching BX values with numeric digits. Like 1000BX,6BX and etc..
Execute the below code and face the desire output.
SELECT F1, Mid(F1,4,Instr (F1, "BX")-2)
FROM tk
WHERE F1 Like '*[0-9]BX*';

Trim more than one spaces between words and keep only one space in MS ACCESS:

We can see three spaces are contain between AA in FNAME column. Execute the below query and see the results.

SELECT Replace(Replace(Replace(Replace(Fname,'  ',' '),'  ',' '),'  ',' '),'  ',' ') AS Expr1

FROM Table1;

Output:

Protect Your Back end code in MS Access :

In this post i will show you how to set a password to protect your back end code from third party's in MS ACCESS.
Step 1 : Open MS ACCESS Database.
Step 2 : Create a new form with a Button
Step 3 : Right Click on that Button and go to Built Event

Step 4 : Go to Tools then Database Properties

Step 5 : Click Protection and set your own choice password

Step 6 : Close your Database and open it again

If Filed exist in MS Access then Drop it:

Function ifFieldExists(ByVal fieldName As String, ByVal TableName As String) As Boolean
Dim db As DAO.Database
    Dim tbl As TableDef
    Dim fld As Field
    Dim strName As String
    Set db = CurrentDb
    Set tbl = db.TableDefs(TableName)
    For Each fld In tbl.Fields
        If fld.Name = fieldName Then
            ifFieldExists = True
            Exit For
        End If
    Next
End Function
Execution Process:
If ifFieldExists("INDC", "Import_process") Then
Else
db.Execute "Alter table Import_process add column INDC text"
End If

IF table exist in MS Access then Drop it :-

Public Function ifTableExists(TableName As String) As Boolean
Dim rs As Recordset 'Sub DAO Vars
On Error GoTo fs
'This checks if a Table is there and reports True or False.
Set db = CurrentDb()
'If Table is there open it
Set rs = db.OpenRecordset("Select * from " & TableName & ";")
ifTableExists = True
rs.Close
db.Close
Exit Function
fs:
'If table is not there close out and set function to false
Set rs = Nothing
db.Close
Set db = Nothing
     ifTableExists = False
  Exit Function
End Function
'Execution Process:-
If ifTableExists("Import_process") Then
db.Execute "Drop table Import_process"
End If

Select only Numeric values from a Column in MS Access:

Public Function fExtractNumeric(strInput) As String
    ' Returns the numeric characters within a string in
    ' sequence in which they are found within the string
    Dim strResult As String, strCh As String
    Dim intI As Integer
    If Not IsNull(strInput) Then
        For intI = 1 To Len(strInput)
            strCh = Mid(strInput, intI, 1)
            Select Case strCh
                Case "0" To "9"
                    strResult = strResult & strCh
                Case Else
            End Select
        Next intI
    End If
    fExtractNumeric = strResult
End Function
OutPut: