Enterprise Software Solutions 

  Jump to: DW University, Employment

Access VBA

Option Compare Database

Private Const strWorksheetName As String = "Data"
Private Const strReportSheetName As String = "Report"
Private Const strWorksheetProtectPassword As String = "DataSystem"

Private DataSystemworkbook As Excel.Workbook

Option Explicit


Public Function OpenDataSystemtemplate() As Boolean
Const strTemplateFile As String = " Report"
Dim ExcelApp As New Excel.Application
Dim Worksheet As Excel.Worksheet
Dim strTemplatePath As String

'open template workbook
strTemplatePath = Replace(GetProperty("name"), ".mdb", "") & strTemplateFile & ".xls"
Set DataSystemworkbook = ExcelApp.Workbooks.Open(strTemplatePath, , True)

'clear old data
Set Worksheet = ExcelApp.ActiveWorkbook.Sheets(strWorksheetName)
Worksheet.Columns.Clear

'indicate success
OpenDataSystemtemplate = True

ExitCleanUp:
'cleanup objects
Set ExcelApp = Nothing
Exit Function
ErrorHandler:
ExcelApp.Visible = True
'indicate failure
OpenDataSystemtemplate = False
'raise error
RaiseSameError "OpenDataSystemtemplate()"
Resume ExitCleanUp
End Function


Public Function PasteInExcel(strQueryName As String, _
iRowToPasteInto As Integer) As Boolean
Dim Worksheet As Excel.Worksheet
Dim db As Database
Dim qdf As QueryDef
Dim rs As Recordset
Dim Field As Field
Dim iCol As Integer

'select data sheet
Set Worksheet = DataSystemworkbook.Sheets(strWorksheetName)

'*****
'paste data
'*****

Set db = CurrentDb
'find the query
For Each qdf In db.QueryDefs
If qdf.Name = strQueryName Then
Exit For
End If
Next qdf
'if not found, then leave now
If qdf.Name <> strQueryName Then
PasteInExcel = False
GoTo ExitCleanUp
End If
'execute the query
Set rs = db.OpenRecordset(qdf.SQL)
If rs.RecordCount = 0 Then
PasteInExcel = False
GoTo ExitCleanUp
End If

'paste the column headers
iCol = 0
For Each Field In rs.Fields
'do not paste the "<>" column
If Field.Name <> "<>" Then
iCol = iCol + 1
'paste the field name
With Worksheet.Cells(rs.AbsolutePosition + iRowToPasteInto, _
iCol)
.FormulaR1C1 = Field.Name
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Font.Bold = True
End With
End If
Next Field

'loop through the recordset
While Not rs.EOF
iCol = 0
For Each Field In rs.Fields
'do not paste the "<>" column
If Field.Name <> "<>" Then
iCol = iCol + 1
'paste the data
With Worksheet.Cells(rs.AbsolutePosition + iRowToPasteInto + 1, _
iCol)
If Field.Type = dbText Then
'make sure that the text format is preserved
.FormulaR1C1 = "= """ & Field.Value & """"
Else
.FormulaR1C1 = Field.Value
End If
End With
End If
Next Field
rs.MoveNext
Wend

'indicate success
PasteInExcel = True

ExitCleanUp:
'cleanup objects
Set Worksheet = Nothing
Set db = Nothing
Set qdf = Nothing
Set rs = Nothing
Set Field = Nothing
Exit Function
ErrorHandler:
DataSystemworkbook.Application.Visible = True
'indicate failure
PasteInExcel = False
'raise error
RaiseSameError "PasteInExcel()"
Resume ExitCleanUp

End Function

'Minimize Excel so that it doesn't pop up
Public Sub MinimizeExcel()
On Error Resume Next
DataSystemworkbook.Application.WindowState = xlMinimized
End Sub

'CleanUpExcel
Public Sub CleanUpExcel()
Dim Worksheet As Excel.Worksheet

'select data sheet
Set Worksheet = DataSystemworkbook.Sheets(strWorksheetName)
'protect the worksheet so that no changes can be made
Worksheet.Protect _
Password:=strWorksheetProtectPassword, _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True

'cleanup private objects
Set DataSystemworkbook = Nothing

ExitCleanUp:
Worksheet.Application.Visible = True
Set Worksheet = Nothing
End Sub

[ Home ] [ Up ]

Send mail to Webmaster@ESScorporation.com with questions or comments about this web site.
Copyright © 2004 Enterprise Software Solutions, Inc.
Last modified: July 29, 2004