DEVelopers HUT

'---------------------------------------------------------------------------------------
' Procedure : GetXLWkSHtFuncVal
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Execute an Excel Worksheet Function from MS Access
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Jan-31             Initial Release
'---------------------------------------------------------------------------------------
Function GetXLWkSHtFuncVal()
   Dim xlApp      As Object
On Error GoTo Error_Handler
 
   Set xlApp = CreateObject("Excel.Application")
   xlApp.Visible = False   'Control whether or not Excel should be visible to
                           'the user or not.
   
   'This is a generic example using the NormInv(), but you can do the same with just
   'about any other Excel Worksheet function.
   GetXLWkSHtFuncVal = xlApp.WorksheetFunction.NormInv(0.25, 4, 1)
 
   xlApp.Quit           'Close the instance of Excel we create

Error_Handler_Exit:
   On Error Resume Next
   Set xlApp = Nothing
   Exit Function
 
Error_Handler:
   MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
   Err.Number & vbCrLf & "Error Source: GetXLWkSHtFuncVal" & vbCrLf & "Error Description: " & _
   Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : ClearXLSWrkSht
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Clear the specified worksheet in a given excel workbook from MS Access
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sXLSFile     Excel workbook filename with full path (ie: "C:\test.xls")
' sXLSWrkSht   Excel worksheet to be cleared (ie: "Sheet1")
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' ClearXLSWrkSht("C:\test.xls", "Sheet1")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Jan-28             Initial Release
'---------------------------------------------------------------------------------------
Sub ClearXLSWrkSht(sXLSFile As String, sXLSWrkSht As String)
   Dim xlApp      As Object
   Dim xlBook     As Object
   Dim xlSheet    As Object
On Error GoTo Error_Handler
 
   Set xlApp = CreateObject("Excel.Application")
   xlApp.Visible = True 'Control whether or not Excel should be visible to
                        'the user or not.
   Set xlBook = xlApp.Workbooks.Open(sXLSFile)  'Open the workbook
   Set xlSheet = xlBook.Worksheets(sXLSWrkSht)  'Worksheet we are working with
   
   xlSheet.Cells.Select
   xlSheet.Cells.ClearContents   'Clear the contents
   
   xlBook.Close True 'Close and save the workbook
   xlApp.Quit        'Close the instance of Excel we create

Error_Handler_Exit:
   On Error Resume Next
   Set xlSheet = Nothing
   Set xlBook = Nothing
   Set xlApp = Nothing
   Exit Sub
 
Error_Handler:
   MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
   Err.Number & vbCrLf & "Error Source: ClearXLSWrkSht" & vbCrLf & "Error Description: " & _
   Err.Description, vbCritical, "An Error has Occured!"
   Resume Error_Handler_Exit
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ListXlsSheets
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : List the sheet name of an Excel Workbook
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile - The Excel file to list the sheets
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-Jul-15                 Initial Release
'---------------------------------------------------------------------------------------
Function ListXlsSheets(sFile As String)
On Error GoTo Error_Handler
    Dim NumSheets   As Integer
    Dim i           As Integer
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
    Dim xlWrkSht    As Object
 
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
    
    If Err.Number <> 0 Then
        'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo Error_Handler
    End If
 
    xlApp.Visible = False 'make excel visible or not to the user
    Set xlWrkBk = xlApp.Workbooks.Open(sFile)
 
    NumSheets = xlWrkBk.Sheets.Count
    For i = 1 To NumSheets
        Debug.Print i & " - " & xlWrkBk.Sheets(i).Name
    Next i
 
    xlWrkBk.Close False
    xlApp.Close
 
    Set xlWrkSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
 
Exit Function
 
Error_Handler:
    If Err.Number <> 438 Then
        MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
        Err.Number & vbCrLf & "Error Source: ListXlsSheets" & vbCrLf & "Error Description: " & _
        Err.Description, vbCritical, "An Error has Occured!"
        Exit Function
    Else
        Resume Next
    End If
 
End Function

'---------------------------------------------------------------------------------------
' Procedure : PrinWrkShtRng
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Print a specified worksheet range
' Copyright : It is not to be altered or distributed,
'             except as part of an application.
'             You are free to use it in any application,
'             provided the copyright notice is left unchanged.
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strWrkBk      Workbook file name(full path and filename)
' strWrkSht     Worksheet name which whose range are to be printed
' strRng        Worksheet Range to be printed
'
'
' Revision History:
' Rev       Date(yyyy/mm)           Description
' **************************************************************************************
' 1         2008-Feb                Initial Release
'---------------------------------------------------------------------------------------
Function PrinWrkShtRng(strWrkBk As String, strWrkSht As String, strRng As String)
On Error GoTo PrinWrkShtRng_Error
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
    Dim xlWrkSht    As Object
 
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
    
    If Err.Number <> 0 Then
        'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo PrinWrkShtRng_Error
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo PrinWrkShtRng_Error
    End If
 
    xlApp.Visible = True 'make excel visible to the user
    Set xlWrkBk = xlApp.Workbooks.Open(strWrkBk)
 
    Set xlWrkSht = xlApp.Worksheets(strWrkSht)
 
    With xlWrkSht.PageSetup
        .PrintArea = strRng
        .Zoom = False
        .FitToPagesTall = 1
        .FitToPagesWide = 1
        .Orientation = xlLandscape
    End With
 
    xlWrkSht.PrintOut Copies:=1
 
    xlWrkBk.Close False
    xlApp.Close
 
    Set xlWrkSht = Nothing
    Set xlWrkBk = Nothing
    Set xlApp = Nothing
 
Exit Function
 
PrinWrkShtRng_Error:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: PrinWrkShtRng" & vbCrLf & _
    "Error Description: " & Err.Description, vbCritical, "An Error has Occured!"
    Exit Function
 
End Function

'---------------------------------------------------------------------------------------
' Procedure : DelWrkSht
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Delete a worksheet from an Excel workbook
' Copyright : It is not to be altered or distributed,
'             except as part of an application.
'             You are free to use it in any application,
'             provided the copyright notice is left unchanged.
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strWrkBk      Workbook to delete the worksheet in/from (full path and filename)
' strWrkSht     Worksheet to be deleted
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-Feb                 Initial Release
'---------------------------------------------------------------------------------------
Function DelWrkSht(strWrkBk As String, strWrkSht As String) As Boolean
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
 
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
    
    If Err.Number <> 0 Then
        'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo DelWrkSht_Error
        Set xlApp = CreateObject("excel.application")
    Else
        On Error GoTo DelWrkSht_Error
    End If
 
    Set xlWrkBk = xlApp.Workbooks.Open(strWrkBk)
 
        xlApp.DisplayAlerts = False 'surpress user confirmation prompt
        xlApp.Worksheets(strWrkSht).Delete
        xlApp.DisplayAlerts = True  'reengage user confirmation prompt
        xlApp.Visible = True
 
    Set xlApp = Nothing
    Set xlWrkBk = Nothing
 
    DelWrkSht = True
 
Exit Function
 
DelWrkSht_Error:
    DelWrkSht = False
    If Err.Number = 9 Then
        'Worksheet not found
        MsgBox "Worksheet '" & strWrkSht & "' not found in Workbook '" & strWrkBk & "'", vbCritical
        Exit Function
    ElseIf Err.Number = 1004 Then
        'Workbook not found
        MsgBox "Unable to locate Workbook '" & strWrkBk & "'", vbCritical
        Exit Function
    Else
        'Othere Errors
        MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
        Err.Number & vbCrLf & "Error Source: basExcel / DelWrkSht" & vbCrLf & _
        "Error Description: " & Err.Description, vbCritical, "An Error has Occured!"
        Exit Function
    End If
End Function