'Const strFolderPath As String = "D:\BO_Logging\Audit_Logs\"  ' logging folder path
Const strFolderPath As String = "C:\Report Debug Logs\"  ' logging folder path
'Const strFilePath As String = "D:\My Documents\My Business Objects Documents\userDocs\"
Const strFilePath As String = "C:\"

Dim FileExists As Boolean
Dim IntCurrentRowPos As Integer


'*****************************************
'Procedure Name: LoadDataProvider
'Purpose: Create Designer object and load/import all universe and write all files to DP for reporting
'Author: jresendez
'Date/Time Created:6/27/2005 / 13:31
'*****************************************
Sub LoadDataProvider(dpInterface As DpVBAInterface)
10      On Error GoTo ErrorHandler

      '**********************************
20      WriteLog ("Begin - LoadDataProvider")
      '**********************************

30    Application.Interactive = False


      Dim i As Integer 'loop index
      Dim Col1 As DpVBAColumn 'a column in the microcube
      Dim Col2 As DpVBAColumn 'a column in the microcube
      Dim Col3 As DpVBAColumn 'a column in the microcube
      Dim Col4 As DpVBAColumn 'a column in the microcube
      'Dim Col5 As DpVBAColumn 'a column in the microcube
      'Dim Col6 As DpVBAColumn 'a column in the microcube

      Dim Cols As DpVBAColumns 'the columns of the microcube
      Dim newCube As DpVBACube 'the microcube we're filling

40    Set newCube = dpInterface.DpVBACubes.Item(1) 'there is only one cube
50    Set Cols = newCube.DpVBAColumns 'reference the columns of the cube
      '70    Cols.SetNbColumns (6) 'how many columns in the cube?
60    Cols.SetNbColumns (4) 'how many columns in the cube?
70    IntCurrentRowPos = 1


80    Set Col1 = Cols.Item(1) 'look at the first column in the cube
90    Col1.Name = "DOC_NAME" 'the name that appears in the report
100   Col1.Type = boCharacterObject 'what sort of information is it?
110   Col1.Qualification = boDimension 'dimension, detail or measure?

120   Set Col2 = Cols.Item(2) 'look at the first column in the cube
130   Col2.Name = "DAY_TIMING" 'the name that appears in the report
140   Col2.Type = boCharacterObject   'what sort of information is it?
150   Col2.Qualification = boDimension 'dimension, detail or measure?


160   Set Col3 = Cols.Item(3) 'look at the first column in the cube
170   Col3.Name = "FREQUENCY" 'the name that appears in the report
180   Col3.Type = boCharacterObject 'what sort of information is it?
190   Col3.Qualification = boDimension 'dimension, detail or measure?


200   Set Col4 = Cols.Item(4) 'look at the first column in the cube
210   Col4.Name = "Next Run DateTime" 'the name that appears in the report
220   Col4.Type = boDateObject 'what sort of information is it?
230   Col4.Qualification = boDimension 'dimension, detail or measure?


      Dim WrkMain As Workspace
      Dim ConMain As Connection
      Dim RsQry As Recordset
      Dim Sql As String
      Dim Rep As Report
      '**********************************
240    WriteLog ("Connect to repository DB to retrieve universe list")
      '**********************************
       
250   Set WrkMain = CreateWorkspace("ODBCWorkspace", "admin", "", dbUseODBC)
260   Set ConMain = WrkMain.OpenConnection("Publishers", dbDriverNoPrompt, False, "ODBC;DATABASE=BUSOBJDB;UID=MYUSERID;PWD=MYPASSWORD;DSN=MYDSN")

270   Sql = "SELECT M_DOC_C_NAME as DocName,day_timing,frequency,begin_date"
280   Sql = Sql & " FROM OBJ_M_DOCUMENTS docs ,DS_PENDING_JOB jobs"
290   Sql = Sql & " WHERE jobs.DOCUMENT_ID = docs.M_DOC_N_ID"
300   Sql = Sql & " AND docs.M_DOC_N_TYPE IN ( 1)"
310   Sql = Sql & " AND jobs.JOB_STATUS IN(4) and frequency Not In(6,4) "
'310   Sql = Sql & "  and frequency Not In(6,4) "



320   Set RsQry = ConMain.OpenRecordset(Sql, dbOpenDynaset)
      Dim dtCurentDate As Date
      Dim dtTomorrow As Date

330   dtCurrentDate = FormatDateTime(Now(), vbShortDate)

340   dtTomorrow = DateAdd("d", 1, dtCurrentDate)



350   If Not RsQry.EOF Then
360       Do While Not RsQry.EOF

       
370                             documentName = RsQry.Fields("DocName")
380                             Day_Timing = RsQry.Fields("DAY_TIMING")
390                               strFrequency = RsQry.Fields("frequency")
400                               BeginTime = RsQry.Fields("begin_date")
                                  


410  ' If FormatDateTime(Seconds2Date(CLng(BeginTime)), vbShortDate) = dtTomorrow Then

420                                 Col1.Item(IntCurrentRowPos) = documentName 'set the value to a number
                                  
430                               Select Case strFrequency
                                      Case 18 'daily
440                                     Col2.Item(IntCurrentRowPos) = GetDaily_WeeklySchedule(CLng(Day_Timing))  'set the value to a number
450                                     Col3.Item(IntCurrentRowPos) = "Daily" 'set the value to a number
460                                   Case 34 'weekly
470                                     Col2.Item(IntCurrentRowPos) = GetDaily_WeeklySchedule(CLng(Day_Timing))  'set the value to a number
480                                     Col3.Item(IntCurrentRowPos) = "Weekly" 'set the value to a number
                                      
490                                   Case (66 Or 64) 'monthly
500                                     Col2.Item(IntCurrentRowPos) = GetMonthly_Schedule(CStr(Day_Timing))  'set the value to a number
510                                     Col3.Item(IntCurrentRowPos) = "Monthly" 'set the value to a number
520                                   Case 130 'monthly interval
530                                     Col2.Item(IntCurrentRowPos) = GetMonthlyInterval_Schedule(CStr(Day_Timing))  'set the value to a number
540                                     Col3.Item(IntCurrentRowPos) = "Monthly Interval" 'set the value to a number
550                                   Case 258 'user-defined
560                                     Col2.Item(IntCurrentRowPos) = "Schedule not Available (See BCA for Schedule Detail)" 'set the value to a number
570                                     Col3.Item(IntCurrentRowPos) = "User Defined" 'set the value to a number"
580                               End Select
590                                   Col4.Item(IntCurrentRowPos) = Seconds2Date(CLng(BeginTime)) 'set the value to a number

600                               IntCurrentRowPos = IntCurrentRowPos + 1
610 '  End If

620     RsQry.MoveNext
630       Loop
640   End If


      '**********************************
650    WriteLog ("Closing Database and Recordset connections")
      '**********************************
660   Set RsQry = Nothing
670   ConMain.Close
680   WrkMain.Close

      '**********************************
690      WriteLog ("Restoring Application.Interactive - TRUE")
      '**********************************
700   Application.Interactive = True

      '**********************************
710    WriteLog ("Exiting Subroutine")
      '**********************************
720   Exit Sub

ErrorHandler:
730       Close #1
740        WriteLog ("ERROR - " & CStr(Err.Number) & " (" & Err.Description & ") Error occured at line number - " & Erl)
          
End Sub

Function GetMonthly_Schedule(IntNumber As String) As String
strSchedule = ""

binMonthlySchedule = ConvertLongDec2Binary(IntNumber)
binMonthlySchedule = CStr(binMonthlySchedule)
'monthly processing



For i = 1 To Len(binMonthlySchedule) - 1

    IntCurrentPos = Mid(binMonthlySchedule, i, 1)
        strSuffix = GetSuffix(CInt(i))
    If IntCurrentPos = "1" Then strDays = strDays & i & strSuffix & ","
    
Next

strDays = Left(strDays, Len(strDays) - 1)
strSchedule = "Report refreshes monthly on the following days: " & strDays & ""
StrLastDayOfMonth = Mid(binMonthlySchedule, 32, 1)

If StrLastDayOfMonth = "1" Then
    strLastMonthString = "and on the last day of the month"
End If

strSchedule = strSchedule & " " & strLastMonthString
GetMonthly_Schedule = strSchedule

End Function

Function GetMonthlyInterval_Schedule(IntNumber As String) As String
strSchedule = ""

binMonthlySchedule = ConvertLongDec2Binary(IntNumber)
binMonthlySchedule = Left(binMonthlySchedule, Len(binMonthlySchedule) - 3)
binMonthlySchedule = CStr(binMonthlySchedule)
'get days of the week
                strDaysOfWeek = Right(binMonthlySchedule, 7)
                strDaysOfWeek = RevString(CStr(strDaysOfWeek))
                strDays = ""
                
                For x = 1 To Len(strDaysOfWeek)
                        IntCurrentPos = Mid(strDaysOfWeek, x, 1)
                        
                        Select Case x
                        Case 1
                            If IntCurrentPos = "1" Then strDays = strDays & "Monday,"
                        Case 2
                            If IntCurrentPos = "1" Then strDays = strDays & "Tuesday,"
                        Case 3
                            If IntCurrentPos = "1" Then strDays = strDays & "Wednesday,"
                        Case 4
                            If IntCurrentPos = "1" Then strDays = strDays & "Thursday,"
                        Case 5
                            If IntCurrentPos = "1" Then strDays = strDays & "Friday,"
                        Case 6
                            If IntCurrentPos = "1" Then strDays = strDays & "Saturday,"
                        Case 7
                            If IntCurrentPos = "1" Then strDays = strDays & "Sunday,"
                        End Select
                Next x
                strDays = Left(strDays, Len(strDays) - 1)

'monthly processing
' strip off already processed characters
binMonthlySchedule = Left(binMonthlySchedule, Len(binMonthlySchedule) - 7)

'process business days or weekdays

            binBusinessWeekDay = Right(binMonthlySchedule, 3)
            
            For y = 1 To Len(binBusinessWeekDay)
                IntCurrentPos = Mid(binBusinessWeekDay, y, 1)
            Select Case y
            Case 1
                   If IntCurrentPos = "1" Then strBusWeek = strBusWeek & "Business Day(s)"
            Case 2
                   If IntCurrentPos = "1" Then strBusWeek = strBusWeek & "Weekday(s)"
            Case 3
                    If IntCurrentPos = "1" Then strBusWeek = strBusWeek & "Day(s)"
            
            
            End Select
            
            Next y
            IntCurrentPos = ""
' strip off already processed characters
binMonthlySchedule = Left(binMonthlySchedule, Len(binMonthlySchedule) - 3)


'process 1st, 2nd, 3rd day(s)..etc

    binStartDay = Right(binMonthlySchedule, 5)
    
    binStartDay = RevString(CStr(binStartDay))
    strStartDay = ""
    
    For k = 1 To Len(binStartDay)
      IntCurrentPos = Mid(binStartDay, k, 1)
      
      Select Case k
      Case 1
          If IntCurrentPos = "1" Then strStartDay = strStartDay & "1st"
      Case 2
          If IntCurrentPos = "1" Then strStartDay = strStartDay & "2nd"
      Case 3
          If IntCurrentPos = "1" Then strStartDay = strStartDay & "3rd"
      Case 4
          If IntCurrentPos = "1" Then strStartDay = strStartDay & "4th"
      Case 5
          If IntCurrentPos = "1" Then strStartDay = strStartDay & "Last"
      
      End Select
      
    Next k
    
IntCurrentPos = ""

binMonthlySchedule = Left(binMonthlySchedule, Len(binMonthlySchedule) - 8)

strEveryXmonth = BinaryToDecimal(CInt(binMonthlySchedule))



If strEveryXmonth > 1 Then
    strMonth = "months"
Else
    strMonth = "month"
End If



strSchedule = "Every " & strStartDay & " " & strDays & " " & strBusWeek & " Every " & strEveryXmonth & "  " & strMonth



GetMonthlyInterval_Schedule = strSchedule

End Function

Function GetDaily_WeeklySchedule(IntNumber As Long) As String
strSchedule = ""

intBin = Dec2Bin2(IntNumber)

intBin = CStr(intBin)


intBin = Left(intBin, Len(intBin) - 3)


intBin = RevString(CStr(intBin))

'daily processing

intDayString = Mid(intBin, 1, 7)

For i = 1 To Len(intDayString)

IntCurrentPos = Mid(intDayString, i, 1)

Select Case i
Case 1
    If IntCurrentPos = "1" Then strDays = strDays & "Monday,"
Case 2
    If IntCurrentPos = "1" Then strDays = strDays & "Tuesday,"
Case 3
    If IntCurrentPos = "1" Then strDays = strDays & "Wednesday,"
Case 4
    If IntCurrentPos = "1" Then strDays = strDays & "Thursday,"
Case 5
    If IntCurrentPos = "1" Then strDays = strDays & "Friday,"
Case 6
    If IntCurrentPos = "1" Then strDays = strDays & "Saturday,"
Case 7
    If IntCurrentPos = "1" Then strDays = strDays & "Sunday,"
   

End Select
Next
strDays = Left(strDays, Len(strDays) - 1)

intBin = Trim(intBin)



intWeeks = Mid(intBin, 19, Len(intBin) - 18)
IntTotalWeeks = 0  'we have at least 1 week


For x = 1 To Len(intWeeks)
IntCurrentWeekPos = Mid(intWeeks, x, 1)

If IntCurrentWeekPos = 1 Then
    IntTotalWeeks = IntTotalWeeks + 1
    Exit For
Else
    IntTotalWeeks = IntTotalWeeks + 1
End If


Next x

If IntTotalWeeks > 1 Then
    strWeeks = "Weeks"
Else
    strWeeks = "Week"
End If




strSchedule = "" & strDays & " Every " & IntTotalWeeks & " " & strWeeks
GetDaily_WeeklySchedule = strSchedule



End Function

Private Sub CheckForFile(file As String)
    Dim fso As New FileSystemObject
    Dim fileFolder
    Dim Folder
        
    Folder = Left(strFilePath, Len(strFilePath) - 1)
    
        
    strFileName = file
    strFileName = Trim(strFileName)
    

If fso.FileExists(strFileName) Then
    FileExists = True
        Else
    FileExists = False
End If



    Set fso = Nothing
    
End Sub

Function ConvertLongDec2Binary(strNumber As String)

 Dim text1$: text1 = strNumber
  Dim NumberHi&, NumberMd&, NumberLo&, temp&, bin$
  Dim xText$: xText = Right$("000000000000000000000" & text1, 21)
  NumberHi = Left$(xText, 7)
  NumberMd = Mid$(xText, 8, 7)
  NumberLo = Right$(xText, 7)
  bin = ""
  Do
    temp = NumberLo Mod 2
    bin = CStr(temp) & bin
    If (NumberHi Mod 2) = 1 Then NumberMd = NumberMd + 10000000
    NumberHi = NumberHi \ 2
    If (NumberMd Mod 2) = 1 Then NumberLo = NumberLo + 10000000
    NumberMd = NumberMd \ 2
    NumberLo = NumberLo \ 2
  Loop Until NumberHi + NumberMd + NumberLo = 0
  'MsgBox "<" & bin & ">"
  ConvertLongDec2Binary = bin
  
End Function

Public Function BinaryToDecimal(Binary As String) As Long
Dim N As Long
Dim s As Integer

    For s = 1 To Len(Binary)
        N = N + (Mid(Binary, Len(Binary) - s + 1, 1) * (2 ^ _
            (s - 1)))
    Next s

    BinaryToDecimal = N
End Function

Function Dec2Bin2(lNumber As Long, Optional lPlaces As Long = 5) As String
    Dim i As Long
    Dim sBin As String
   
    i = 1
       
    Do
        sBin = IIf((Abs(lNumber) And i) = 0, "0", "1") & sBin
        i = i * 2
    Loop Until i > Abs(lNumber)
   
    For i = Len(sBin) + 1 To lPlaces
        sBin = "0" & sBin
    Next i
       
    Do Until Len(sBin) Mod 4 = 0
        sBin = "0" & sBin
    Loop
    
    If lNumber < 0 Then
        Dec2Bin2 = TwosComp(sBin)
    Else
        Dec2Bin2 = sBin
    End If
   
End Function

Function TwosComp(sBin As String) As String
   
    Dim i As Long
    Dim lNum As Long
    Dim sTemp As String
   
    For i = 1 To Len(sBin)
        sTemp = sTemp & IIf(Mid(sBin, i, 1) = 0, "1", "0")
    Next i
   
    For i = Len(sTemp) To 1 Step -1
        lNum = lNum + ((2 ^ (i - 1)) * Val(Mid$(sTemp, Len(sTemp) - i + 1, 1)))
    Next i
   
    TwosComp = Dec2Bin2(lNum + 1, Len(sBin))
   
End Function

'WRITELOG
Function WriteLog(LogTxt As String, Optional EndProcessBrk As Boolean)
Dim Doc As Document
Dim StrLogFile
Set Doc = ThisDocument

StrLogFile = strFolderPath & Doc.Name & "_Audit_Log" & "_" & Format(Now(), "yyyy_mm_dd") & ".log"

Open StrLogFile For Append As #1
    Print #1, Now() & " -- " & LogTxt & vbCrLf;
        
        If EndProcessBrk Then
            Print #1, vbCrLf & vbCrLf;
        End If

Close #1

Exit Function
End Function

 Function Seconds2Date(lSecond As Long) As Date
    
    Dim dStart As Date
    Dim dNew As Date
    Dim lTemp As Long
    Dim dblTemp As Double
    Dim nDays As Long
    Dim nHours As Long
    Dim nMinutes As Long
    
    dblTemp = lSecond / 24 / 60 / 60
    nDays = Floor(dblTemp)
    lTemp = nDays * 24 * 60 * 60
    lSecond = lSecond - lTemp
    
    dblTemp = lSecond / 60 / 60
    nHours = Floor(dblTemp)
    lTemp = nHours * 60 * 60
    lSecond = lSecond - lTemp
    
    dblTemp = lSecond / 60
    nMinutes = Floor(dblTemp)
    lTemp = nMinutes * 60
    lSecond = lSecond - lTemp
    
    dStart = #12/15/1970#
    
    dNew = DateAdd("d", nDays, dStart)
    dNew = DateAdd("h", nHours, dNew)
    dNew = DateAdd("n", nMinutes, dNew)
    dNew = DateAdd("s", lSecond, dNew)
    
    Seconds2Date = dNew
    
End Function

Function Floor(dvalue As Double) As Double
    Dim sTemp As String
    Dim nTemp As String
    
    sTemp = Format(dvalue, "0.000000000")
    nTemp = InStr(1, sTemp, ".")
    If nTemp > 0 Then
        sTemp = Mid(sTemp, 1, nTemp)
    End If
    Floor = CDbl(sTemp)
End Function

Function RevString(A As String) As String
    Dim B As String, C As String
    Dim J As Integer
    
    B = A
    C = ""
    For J = 1 To Len(B)
        C = Mid(B, J, 1) + C
    Next J
    RevString = C
End Function

'SPLITSTRING
Function SplitString(sText As String, sDelim As String) As Variant

On Error Resume Next

  Dim TextLen As Long, DelimLen As Long
  Dim Pieces() As String
  Dim N As Long, i As Long, J As Long

  TextLen = Len(sText)
  DelimLen = Len(sDelim)
  ReDim Pieces(1 To 1)
  
  If DelimLen = 0 Then
    Pieces(1) = sText
  Else
    N = 0
    i = 1
    Do
      J = InStr(i, sText, sDelim)
      If J = 0 Then J = TextLen + 1
      N = N + 1
      ReDim Preserve Pieces(1 To N)
      Pieces(N) = Mid$(sText, i, J - i)
      i = J + DelimLen
    Loop Until J > TextLen
  End If
  
  SplitString = Pieces()
  
End Function

Function GetSuffix(IntSuffix As Integer)
Dim strAbbrev As String
strAbbrev = ""

IntSuffix = CInt(IntSuffix)

Select Case IntSuffix
Case 1
    strAbbrev = "st"
Case 21
    strAbbrev = "st"
Case 31
    strAbbrev = "st"
Case 2
    strAbbrev = "nd"
Case 22
    strAbbrev = "nd"
Case 3
    strAbbrev = "rd"
Case 23
    strAbbrev = "rd"
Case Else
        strAbbrev = "th"
End Select
GetSuffix = strAbbrev

End Function