I needed to export data from access and do some formatting at the same time. So this code helped me to perform this.
Private Sub Command0_Click()
Dim db As DAO.Database
Set db = CurrentDb()
' Drop table if exists
If ifTableExists("ACCESS_TABLE") Then db.Execute "DROP Table ACCESS_TABLE"
' Import data from SQL table
DoCmd.TransferDatabase acTable, "ODBC Database", _
"ODBC;Driver={SQL Server};Server=192.168.0.0;UID=username;PWD=password;LANGUAGE=us_english;" _
& "DATABASE=DatabaseName", acTable, "SQL_TABLE", "ACCESS_TABLE"
'Excel Export and Formatting
Dim n1 As String
Dim xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim xlsheet1 As Excel.Worksheet
n1 = CurrentProject.Path + "\DestinationExcelName.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ACCESS_TABLE", n1, True
On Error Resume Next
Set xl = GetObject(n1, "Excel.Application")
On Error GoTo 0
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set XlBook = GetObject(n1)
'Make sure excel is visible on the screen
xl.Visible = True
XlBook.Windows(1).Visible = True
'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
XlBook.Activate
AppActivate xl.Caption
With xlsheet1
.range("A1:C1").Interior.Color = RGB(192, 192, 192) ' Grey "Fill color"
.range("D1:F1").Interior.Color = RGB(255, 255, 0) ' Yellow "Fill color"
.range("G1:I1").Interior.Color = RGB(255, 204, 153) ' Orange "Fill color"
.range("A1:C1").Font.Color = RGB(255, 255, 255) ' White "Font color"
.rows("1:1").Font.Bold = True ' "Font weight - Bold"
End With
XlBook.Save
MsgBox "DestinationExcelName.xlsx file exported. Please check"
End Sub
Public Function ifTableExists(tablename As String) As Boolean
ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tablename & "'") = 1 Then
ifTableExists = True
Else
ifTableExists = False
End If
End Function
Dim db As DAO.Database
Set db = CurrentDb()
' Drop table if exists
If ifTableExists("ACCESS_TABLE") Then db.Execute "DROP Table ACCESS_TABLE"
' Import data from SQL table
DoCmd.TransferDatabase acTable, "ODBC Database", _
"ODBC;Driver={SQL Server};Server=192.168.0.0;UID=username;PWD=password;LANGUAGE=us_english;" _
& "DATABASE=DatabaseName", acTable, "SQL_TABLE", "ACCESS_TABLE"
'Excel Export and Formatting
Dim n1 As String
Dim xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim xlsheet1 As Excel.Worksheet
n1 = CurrentProject.Path + "\DestinationExcelName.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ACCESS_TABLE", n1, True
On Error Resume Next
Set xl = GetObject(n1, "Excel.Application")
On Error GoTo 0
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set XlBook = GetObject(n1)
'Make sure excel is visible on the screen
xl.Visible = True
XlBook.Windows(1).Visible = True
'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
XlBook.Activate
AppActivate xl.Caption
With xlsheet1
.range("A1:C1").Interior.Color = RGB(192, 192, 192) ' Grey "Fill color"
.range("D1:F1").Interior.Color = RGB(255, 255, 0) ' Yellow "Fill color"
.range("G1:I1").Interior.Color = RGB(255, 204, 153) ' Orange "Fill color"
.range("A1:C1").Font.Color = RGB(255, 255, 255) ' White "Font color"
.rows("1:1").Font.Bold = True ' "Font weight - Bold"
End With
XlBook.Save
MsgBox "DestinationExcelName.xlsx file exported. Please check"
End Sub
Public Function ifTableExists(tablename As String) As Boolean
ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tablename & "'") = 1 Then
ifTableExists = True
Else
ifTableExists = False
End If
End Function
No comments:
Post a Comment