Option Explicit

'
Public Sub ShowFrmMain()
  ' This has to be application global or Excel will complain
  FrmMain.Show
End Sub

Public Sub AutoOpen()
  Sheets("Data").Select
  FrmMain.Show
End Sub

Public Sub FastDMRtoExcel(TheDMRQueryString As String, NumRecordsWanted As Long, _
                   OracleServer As String)

  ' Accounts
   
  Dim OracleAccount(25) As String
    
  OracleAccount(1) = "someuserid/somepassword"
  
  'OO4O
  Dim OraSession As OracleInProcServer.OraSessionClass
  Dim OraDatabase As OracleInProcServer.OraDatabase
  Dim EmpDynaset As OracleInProcServer.OraDynaset
  Dim ColNames As OracleInProcServer.OraFields
  Dim AnOracleField As OracleInProcServer.OraField
   
  'ADO
  Dim ClientRS As ADODB.Recordset, AnADOField As ADODB.Field
   
  'Excel
  Dim RowLoop As Long, ColumnLoop As Long, ColumnRange As String
  
  'Helpers
  Dim TheCount As Long, TheOracleQuery As String, ToUser As Variant
  Dim StartTime As Date, EndTime As Date
  Dim Buildup As String, Looper As Long
   
  TheOracleQuery = TheDMRQueryString
   
  If NumRecordsWanted = 1 Then NumRecordsWanted = 2
  If NumRecordsWanted > 0 Then
    If InStr(1, UCase(TheOracleQuery), "WHERE", vbTextCompare) > 0 Then
      TheOracleQuery = TheOracleQuery & " AND ROWNUM < " & NumRecordsWanted + 1
    Else
      TheOracleQuery = TheOracleQuery & " WHERE ROWNUM < " & NumRecordsWanted + 1
    End If
  End If
   
  On Error Resume Next
  Set OraSession = New OracleInProcServer.OraSessionClass
  If Err.Number <> 0 Then
    FrmMain.Controls("lblStatusWindow").Caption = "Oracle Objects for OLE are not registered."
    ToUser = MsgBox("The Oracle Objects for OLE do not appear to be registered " & vbCrLf & _
                    "on your system. This tool will work only if the OO4O " & vbCrLf & _
                    "version 4.0 or higher are installed on your system.", vbCritical, _
                    "GQA - Error: Oracle Objects for OLE 4.0 not installed")
    On Error GoTo 0
    Exit Sub
  End If
   
  StartTime = Now
   
  On Error GoTo pastcase
  Select Case OracleServer
    Case "server1"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(1), 0&)
      GoTo successfulconnect
    Case "server2"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(2), 0&)
      GoTo successfulconnect
    Case "server3"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(3), 0&)
      GoTo successfulconnect
    Case "server4"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(4), 0&)
      GoTo successfulconnect
    Case "server5"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(5), 0&)
      GoTo successfulconnect
    Case "server6"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(6), 0&)
      GoTo successfulconnect
    Case "server7"
      Set OraDatabase = OraSession.OpenDatabase(OracleServer, OracleAccount(7), 0&)
      GoTo successfulconnect
    Case Else
  End Select
   
pastcase:
   
  If Err.Number <> 0 Then
    FrmMain.Controls("lblStatusWindow").Caption = "Error connecting to Oracle."
    ToUser = MsgBox("Could not connect to Oracle Server: " & vbCrLf & _
                    OraSession.LastServerErr & "-" & _
                    OraSession.LastServerErrText, vbCritical, _
                    "GQA - Connection to Oracle Server Failed")
    On Error GoTo 0
    Exit Sub
  End If
      
successfulconnect:
  
  ' I had to do it this way because that particular system had extra security due to
  ' military data being on it
  If Left(OracleServer, 3) = "BRG" Then
    On Error Resume Next
    OraDatabase.ExecuteSQL ("CALL MMI.AUTHORIZE()")
    If Err.Number <> 0 Then
      FrmMain.Controls("lblStatusWindow").Caption = "Error executing MMI.AUTHORIZE."
      ToUser = MsgBox("MMI.AUTHORIZE call failed - " & OraSession.LastServerErr, _
                      vbCritical, "MMI.AUTHORIZE procedure attempt")
      On Error GoTo 0
      OraDatabase.Close
      Set OraSession = Nothing
      On Error GoTo 0
      Exit Sub
    End If
  End If
  
  On Error Resume Next
  Set EmpDynaset = OraDatabase.CreateDynaset(TheOracleQuery, 0&)
  
  If Err.Number <> 0 Then
  
    FrmMain.Controls("lblStatusWindow").Caption = "Error Processing Query."
    ToUser = MsgBox("Error processing query: " & vbCrLf & Err.Description & _
                    "===========================================" & vbCrLf & _
                    "--->" & TheOracleQuery & "<---" & vbCrLf & _
                    "===========================================", _
                     vbCritical, "GQA - Query Failed")
    On Error GoTo 0
    OraDatabase.Close
    Set OraSession = Nothing
    Exit Sub
  
  Else
    
    If EmpDynaset.RecordCount * EmpDynaset.Fields.Count > 1349999 Then
      EndTime = Now
      Buildup = GetElapsedTime(StartTime, EndTime, DAY_HOUR_MIN_SEC)
      FrmMain.Controls("lblStatusWindow").Caption = "Volume of returned data extremely high!" & _
                       " (" & Format(EmpDynaset.RecordCount, "###,###,###,###") & _
                       " records in " & Buildup & ")"
      ToUser = MsgBox("The query results are large enough that there is a " & vbCrLf & _
               "possibility that your machine may crash. Is this OK?", vbYesNo, _
               "GQA - Returned Dataset Very Large")
      If ToUser = 7 Then Exit Sub
    End If
    
  End If
    
  ' ===
    ' Disconnected Recordset. Fill it with data from the Oracle recordset, then
    ' disconnect from Oracle as fast as possible so as not to hold Oracle up
    
  Set ClientRS = New ADODB.Recordset
  With ClientRS
    .CursorLocation = adUseClient
    .ActiveConnection = Nothing
    Set ColNames = EmpDynaset.Fields
    For Each AnOracleField In ColNames
      .Fields.Append Name:=AnOracleField.Name, Type:=adVarChar, _
       DefinedSize:=gblFieldDefinedSize, attrib:=adFldIsNullable
    Next
    .Open
    While Not EmpDynaset.EOF
      .AddNew
      For Each AnOracleField In EmpDynaset.Fields
        .Fields(AnOracleField.Index).Value = _
         EmpDynaset.Fields(AnOracleField.Index).Value
      Next
      .Update
      EmpDynaset.MoveNext
    Wend
  End With
    
  
  ' ===

  EmpDynaset.Close
  Set EmpDynaset = Nothing
  Set OraSession = Nothing
  
  TheCount = ClientRS.RecordCount

  If TheCount > 65535 Then
    FrmMain.Controls("lblStatusWindow").Caption = "Volume of returned data exceeds " & _
                     "worksheet size."
    ToUser = MsgBox("The query results exceed 65,535 records and won't fit in " & _
                    "a standard Excel worksheet. Is this OK?", vbYesNo, _
                    "GQA - Returned Dataset Exceeds worksheet size")
    If ToUser = 7 Then Exit Sub
  End If
 
  ClientRS.MoveFirst
   
  Worksheets("Data").Cells.Clear
  Application.Goto Reference:=Worksheets("Data").Range("A1"), scroll:=True
  RowLoop = 1
  While Not ClientRS.EOF
    ColumnLoop = 1
      If RowLoop < 2 Then
        For Each AnADOField In ClientRS.Fields
          With Worksheets("Data").Range("A1").Rows(1).Columns(ColumnLoop)
            .Value = AnADOField.Name
            .Font.Bold = True
            .Font.Italic = True
            .Font.Underline = xlUnderlineStyleSingle
            .HorizontalAlignment = xlCenter
          End With
          ColumnLoop = ColumnLoop + 1
        Next
      Else
        For Each AnADOField In ClientRS.Fields
          Worksheets("Data").Range("A1").Rows(RowLoop).Columns(ColumnLoop).Value = _
          ClientRS(AnADOField.Name).Value
          ColumnLoop = ColumnLoop + 1
        Next
        ClientRS.MoveNext
      End If
      RowLoop = RowLoop + 1
  Wend
   
  If RowLoop < 2 Then
    Application.ActiveCell = "(No records returned)"
    ColumnRange = "A:A"
  Else
    ColumnRange = "A:IV"
  End If
      
  With Columns(ColumnRange)
    .EntireColumn.AutoFit
    .HorizontalAlignment = xlCenter
  End With
  
  EndTime = Now
  Buildup = GetElapsedTime(StartTime, EndTime, DAY_HOUR_MIN_SEC)
  
  If RowLoop < 2 Then
    FrmMain.Controls("lblStatusWindow").Caption = _
    "Query retrieved no records. Processing time was: " & Trim(Buildup) & "."
  Else
    FrmMain.Controls("lblStatusWindow").Caption = _
    "Retrieved and wrote " & TheCount & " Records In " & Trim(Buildup) & "."
  End If
  
End Sub 'FastDMRtoExcel

Public Function GetElapsedTime(dteStart As Date, dteEnd As Date, lngFormat _
                               As opgTimeInterval) As String
                        
  ' Formats elapsed time as seconds, minutes:seconds, hours:minutes:seconds,
  ' or days, hours, minutes, seconds.
    
  Dim dblInterval     As Double
  Dim lngTotalHours   As Long
  Dim lngTotalMins    As Long
  Dim lngTotalSecs    As Long
  Dim lngDays         As Long
  Dim lngHours        As Long
  Dim lngMins         As Long
  Dim lngSecs         As Long
  Dim strElapsed      As String
    
  Dim ElapsedTime() As String
  Dim Magnitude(3) As String
  Dim Outstring As String, Looper As Long
  
  Magnitude(0) = "Days"
  Magnitude(1) = "Hours"
  Magnitude(2) = "Minutes"
  Magnitude(3) = "Seconds"
   
  dblInterval = Abs(dteEnd - dteStart)
    
  lngDays = Int(CSng(dblInterval))
  lngTotalHours = Int(CSng(dblInterval * 24))
  lngTotalMins = Int(CSng(dblInterval * 1440))
  lngTotalSecs = Int(CSng(dblInterval * 86400))
    
  ' Determine fractional times.
  lngHours = lngTotalHours Mod 24
  lngMins = lngTotalMins Mod 60
  lngSecs = lngTotalSecs Mod 60
    
  Select Case lngFormat
    Case opgTimeInterval.SEC
      strElapsed = lngTotalSecs
    Case opgTimeInterval.MIN_SEC
      strElapsed = lngTotalMins & ":" & Format$(dblInterval, "ss")
    Case opgTimeInterval.HOUR_MIN_SEC
      strElapsed = lngTotalHours & ":" & Format$(dblInterval, "nn") _
                   & ":" & Format$(dblInterval, "ss")
    Case opgTimeInterval.DAY_HOUR_MIN_SEC
      strElapsed = lngDays & ":" & lngHours & ":" & lngMins & ":" & lngSecs
  End Select
    
  ElapsedTime = Split(strElapsed, ":", 4, vbTextCompare)
  Outstring = ""
  For Looper = 0 To 3
    If ElapsedTime(Looper) > 0 Then
      Outstring = Outstring & ElapsedTime(Looper) & " " & Magnitude(Looper) & " "
    End If
  Next
  
  If Len(Outstring) < 7 Then Outstring = "Less than 1 second"

  GetElapsedTime = Outstring
  
End Function 'GetElapsedTime