Attribute VB_Name = "mod_Report"
Public Sub OpenReport(ByVal strReportFileName As String, ParamArray strParameters())
On Error GoTo ErrHandler
    Dim crViewer As Object
    Set crViewer = CreateObject("MedsysCrystalReportViewer")

    Dim paramModel As Object
    Set paramModel = CreateObject("Medsys.CrystalViewer.ParameterModel")

    ' SET Report Parameter Value
    Dim intTotalParam As Integer
    intTotalParam = UBound(strParameters)
    
    Dim reportParam() As String
    ReDim reportParam(intTotalParam) As String
    
    Dim intCtr As Integer
    intCtr = 0
    
    Dim intCount As Integer
    If intTotalParam >= 0 Then
      For intCount = 0 To intTotalParam
         If intTotalParam >= intCtr Then
            reportParam(intCount) = strParameters(intCount)
         Else
            Exit For
         End If
         intCtr = intCount + 1
      Next
   End If
   
    ' SET CrystalReport ParameterModel
    paramModel.FilePath = Left(strReportFileName, InStrRev(strReportFileName, "\"))
    paramModel.filename = Mid(strReportFileName, InStrRev(strReportFileName, "\") + 1)
    paramModel.ParameterValue = reportParam
    
    crViewer.SetLogOnInfo CurrentUser.ServerName, gDatabase, CurrentUser.UserID, CurrentUser.serverpassword
    crViewer.ShowExportButton (True)
    crViewer.OpenReport paramModel
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, ""
End Sub


Public Sub OpenMainReport(ByVal strReportFileName As String, ParamArray strParameters())
On Error GoTo Errmessage:

   Dim crxParameterField As CRAXDRT.ParameterFieldDefinition
   Dim intCtr As Integer
   Dim intTotalParam As Integer
   Dim crxTable As CRAXDRT.DatabaseTable
   Dim crxApplication As New CRAXDRT.Application
   Dim strDatabaseName As String
   blnShowReport = True
   strDatabaseName = gDatabase
   Dim strClientName As String
   
    strSQL = "select clientname from patient_data..tbhospitalinfo"
        With conFA.Execute(strSQL)
        If .RecordCount > 0 Then
            strClientName = (!clientname & "")
        End If
    End With
    
    
    Dim IntCountA As Integer
    Dim IntCountB As Integer
    Dim filename As String
    
    IntCountA = Len(App.Path & "\Reports\")
    IntCountB = Len(strReportFileName) - IntCountA
    
    filename = Right(strReportFileName, IntCountB)
    
    If File_Exists(App.Path & "\Reports\customised\" & filename) Then
        strReportFileName = App.Path & "\Reports\customised\" & filename
    ElseIf File_Exists(App.Path & "\Reports\" & filename) Then
        strReportFileName = App.Path & "\Reports\" & filename
    Else
        MsgBox filename & " not exists. Please contact IT Department.", vbCritical + vbOKOnly, gblMessageBoxTitle
        blnShowReport = False
        Exit Sub
    End If
    
    
    
    
     
   intCtr = 0
   intTotalParam = UBound(strParameters)
   Set Report = crxApplication.OpenReport(strReportFileName, 1)
   Report.ReportTitle = gblTitleReport
   For Each crxTable In Report.Database.Tables
      crxTable.Location = strDatabaseName + Mid(crxTable.Location, InStr(1, crxTable.Location, "."))
      crxTable.SetLogOnInfo CurrentUser.ServerName, strDatabaseName, CurrentUser.UserID, CurrentUser.serverpassword
   Next

   If intTotalParam >= 0 Then
      For Each crxParameterField In Report.ParameterFields
         If intTotalParam >= intCtr Then
            crxParameterField.AddCurrentValue strParameters(intCtr)
         Else
            Exit For
          End If
         intCtr = intCtr + 1
      Next
   End If
   Set crxParameterField = Nothing
   Set crxTable = Nothing
   Set crxApplication = Nothing
   Exit Sub
Errmessage:
MsgBox "Error loading Sub OpenMainReport(). " & strRptFileName & " -- " & Err.Description & ". Please contact EDP/IRM for assistance.", vbCritical, App.Title
blnShowReport = False
Exit Sub
End Sub

Public Sub OpenSubReport(ByVal strSubReport As String, ParamArray strParameters())
   Dim crxParameterField As CRAXDRT.ParameterFieldDefinition
   Dim intCtr As Integer
   Dim intTotalParam As Integer
   Dim crxTable As CRAXDRT.DatabaseTable
   Dim crxApplication As New CRAXDRT.Application
   Dim strDatabaseName As String
   
   strDatabaseName = gDatabase
                   
   intTotalParam = UBound(strParameters)
   Set crxSubreport = Report.OpenSubReport(strSubReport)
   crxSubreport.ReportTitle = sHospitalName
   For Each crxTable In crxSubreport.Database.Tables
      crxTable.Location = strDatabaseName + Mid(crxTable.Location, InStr(1, crxTable.Location, "."))
      crxTable.SetLogOnInfo CurrentUser.ServerName, strDatabaseName, CurrentUser.UserID, CurrentUser.serverpassword
   Next
                
   If intTotalParam >= 0 Then
      For Each crxParameterField In crxSubreport.ParameterFields
         If intTotalParam >= intCtr Then
            crxParameterField.AddCurrentValue strParameters(intCtr)
         Else
            Exit For
         End If
         intCtr = intCtr + 1
      Next
   End If
   Set crxParameterField = Nothing
   Set crxTable = Nothing
   Set crxSubreport = Nothing
End Sub

Public Sub ShowReportViewer(Optional blnShowGroupTree As Boolean = False, Optional strCaption As String = "", Optional blnDirectToPrinter As Boolean = False)
  On Error GoTo errTrap:
   Dim frmRView As New frmReportViewer
   With frmRView
      .ShowGroupTree = blnShowGroupTree
      .Caption = strCaption
      .DirectPrint = blnDirectToPrinter
      .Show vbModal
   End With
   Exit Sub
errTrap:
MsgBox Err.Description, vbCritical, "Sub.Showreportviewer"
End Sub

Public Sub PrintToPrinter(promptUser As Boolean, noCopies As Integer)
    Report.PrintOut promptUser, noCopies
    
    Set Report = Nothing
End Sub

Public Function SetLogOnInfo(crxTable As CRAXDRT.DatabaseTable, strDatabaseName As String)
    With CurrentUser
        crxTable.Location = strDatabaseName + Mid(crxTable.Location, InStr(1, crxTable.Location, "."))
        crxTable.SetLogOnInfo .ServerName, strDatabaseName, .UserID, .serverpassword
    End With
End Function
Public Function FileExists(sFullPath As String) As Boolean
    Dim oFile As New Scripting.FileSystemObject
    FileExists = oFile.FileExists(sFullPath)
End Function
Public Sub ExportXLS(Optional strfilename As String = "")
    
    Dim strMyDocuments As String
    Dim strDiskName As String
    '
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    strMyDocuments = WshShell.SpecialFolders("MyDocuments")
    
    '       strMyDocuments = Environ$("USERPROFILE")
    '                If Len(strMyDocuments) = 0 Then
    '                    strMyDocuments = "C:\My Documents"
    '                Else
    '                    strMyDocuments = fs.BuildPath(strMyDocuments, "My Documents")
    '                End If
    
    strDiskName = fs.BuildPath(strMyDocuments, fs.GetBaseName(strfilename) & "." & Format$(Now, "yyyy.MM.dd.hh.mm.ss") & ".xls")
    If MsgBox("Do you wish to export the report?", vbYesNo, "Export Report to Disk") = vbYes Then
        Report.ExportOptions.DiskFileName = strDiskName
        Report.ExportOptions.DestinationType = crEDTDiskFile
        Report.ExportOptions.FormatType = crEFTExcel80
        Report.Export False
        MsgBox "Report was successfully exported to " + strDiskName, vbInformation, "Information"
    End If
End Sub