Link to home
Start Free TrialLog in
Avatar of kmscommsteam
kmscommsteamFlag for United States of America

asked on

How to resolve the error message "Compile time error in hidden module: Module 11" in MS Excel applications?

Whenever I try to open my MS excel application, I come across this error message and the application hangs up. Some users are able to access this application whereas some users cannot proceed further after this message. Also attached is the Module 11 code for this application. How can this be rectified?
Option Explicit
                                     
Dim i, j, k, l, m, n, p, intCnt, allowedPTOlimit As Integer
Dim resName() As String
Dim nDate, tDate, xDate As Date
Dim iState, iDone As Boolean
Dim ArrTmpA() As String
Dim ArrRes(60, 600) As String
Dim ArrResMail(60, 600) As String
Dim ArrKey(20) As String
Dim ArrDate(60) As String
Dim ArrPTO(60) As String
Dim ArrPTOAdmin(60, 600) As String
Dim strWE As String
Dim cntPG() As String
Dim hwPG As Integer
Global FilePath, FilePassword, FileModifyPassword, BackUPFilePath As String
Global InfoFilePath, InfoFilePassword, InfoFileModifyPassword As String
 
   Global arrTemp() As String
   Global arrMail() As String
   Global strTemp, strTemp1, strTemp2, strDef As String
 
Global IsUser As Boolean
Global prjName As String
Global sDate, eDate As Date
Global strUser As String
Global isAdmin As Boolean
Global iCheck As Boolean
Global strOtherHalfStatus As String
 
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
     (ByVal lpBuffer As String, nSize As Long) As Long
 
Sub ShowIt()
    UserForm1.Show
End Sub
 
Function SaveReport(Optional ByVal isPTO As Boolean) As Boolean
Dim CheckNameStatus, CheckHalf As Boolean
Dim AdjDate As Integer
 
If Sheets("PTO Planner").opHalf.Value = True Then
CheckHalf = True
Else
CheckHalf = False
End If
 
CheckNameStatus = False
Sheets("Resource Scheduler").Image1.Visible = True
ArrTmpA = Split(Sheets("Resource Scheduler").Label8.Caption, ": ")
intCnt = ArrTmpA(1) + 2
 
If Sheets("PTO Planner").Label3.Visible = False Then isAdmin = True
iState = False
If isAdmin = True Then
strUser = Sheets("Resource Scheduler").TextBox1.Text
Else
strUser = Sheets("Resource Scheduler").TextBox1.Text
End If
resName = Split(strUser, " ")
tDate = Date
 
If sDate - Date < 0 And isPTO = False And isAdmin = False Then
MsgBox "Sorry! You cannot change past entries.", vbExclamation + vbOKOnly, "Business Research Center"
End
End If
 
Application.StatusBar = "Accessing master file... Please wait."
Application.ScreenUpdating = False
 
 
DefFileVars
Workbooks.Open notify:=False, Filename:=FilePath, Password:=FilePassword, writerespassword:=FileModifyPassword
        
ActiveWorkbook.Sheets("Check").Select
 
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value <> Date Then
ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value = Date
ActiveWorkbook.SaveCopyAs Filename:=BackUPFilePath & ActiveWorkbook.Name
End If
 
For i = 2 To intCnt + 1
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, i).Value = resName(0) Then p = i
Next
 
n = 0
For k = 0 To eDate - sDate
    l = 1
    iState = False
    j = 1
    nDate = sDate + k
        If Weekday(nDate, vbMonday) > 5 Then
        'MsgBox "Entry denied for " & Format(nDate, "Mmm DD, YY") & ". This date may come under weekend or holiday."
        ArrKey(n) = Format(nDate, "Mmm DD, YY")
        n = n + 1
        Else
        Do While iState = False
            If j > 1000 Then
            ArrKey(n) = Format(nDate, "Mmm DD, YY") & "*"
            n = n + 1
            GoTo RSVP1
            End If
            If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(j, 0).Value = nDate Then
                If Left(prjName, 3) = "PTO" And isAdmin = False Then
                    For i = 2 To intCnt + 1
                        If i <> p And Left(ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(j, i).Value, 3) = "PTO" Then l = l + 1
                    Next
                If l < 10 Then l = "0" & l
                If CheckNameStatus Then
                prjName = Replace(prjName, Mid(prjName, 14, 7), "")
                prjName = prjName & "//" & l
                Else
                prjName = prjName & "//" & l
                End If
                
                If CheckHalf = True Then
                prjName = prjName & "//" & "H" & "++" & strOtherHalfStatus
                Else
                prjName = prjName & "//" & "F"
                End If
                
                CheckNameStatus = True
                End If
                
                Dim tmpPrjName, xpName  As String
                If Left(prjName, 3) = "PTO" Then
                xpName = "PTO (Request Pending)... A new request will be alloted to you."
                Else
                xpName = prjName
                End If
                
                tmpPrjName = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(j, p).Value
                
                Select Case InStr(tmpPrjName, "PTO")
                Case Is > 0
                If MsgBox("You are trying to update an existing PTO record. Do you want to update your status as follow:" & vbCrLf & vbCrLf & _
                "Current Record: PTO" & vbCrLf & vbCrLf & _
                "New Status: " & xpName, vbYesNo, "Replacing Record...") = vbNo Then prjName = tmpPrjName
                Case Else
                'Do Nothing
                End Select
                
                If isAdmin = True And Left(prjName, 3) <> "PTO" Then
                        ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(j, p).Value = prjName & " (Admin)"
                Else
                        ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(j, p).Value = prjName
                End If
            
            iState = True
            End If
        j = j + 1
        Loop
        End If
RSVP1:
Next
 
    ActiveWindow.Close True
    Application.ScreenUpdating = True
    Application.StatusBar = False
    
    If isPTO Then
    Sheets("PTO Planner").Select
    If ArrKey(0) <> "" Then
    strWE = ""
    For i = 0 To n - 1
    If InStr(ArrKey(i), "*") > 0 Then
        strWE = strWE & Chr(10) & "- " & ArrKey(i) & " (Firm Holiday)"
    Else
        strWE = strWE & Chr(10) & "- " & ArrKey(i) & " (" & WeekdayName(Weekday(ArrKey(i))) & ")"
    End If
    Next
    'MsgBox "Request successfully completed with following messages:" & vbCrLf & vbCrLf & "Entry denied for following date as they fall either on weekend or on holiday." & strWE, vbInformation + vbOKOnly, "Business Research Center"
    Range("N28").Value = "PTO request has been sent to Team Leads." & Chr(10) & Chr(10) & "Scheduler messages:" & Chr(10) & "Entry denied for following date as they fall either on weekend or on holiday." & strWE & Chr(10) & Chr(10) & "Check status using PTO Planner"
    Else
    'MsgBox "Request successfully completed with following messages:" & vbCrLf & vbCrLf & "Entries updated.", vbInformation + vbOKOnly, "Business Research Center"
    Range("N28").Value = "PTO request has been sent to Team Leads." & Chr(10) & Chr(10) & "Scheduler messages:" & Chr(10) & "Check status using PTO Planner"
    End If
    Range("G7").Select
    Else
    Sheets("Resource Scheduler").Select
    If ArrKey(0) <> "" Then
    strWE = ""
    For i = 0 To n - 1
    If InStr(ArrKey(i), "*") > 0 Then
        strWE = strWE & Chr(10) & "- " & ArrKey(i) & " (Firm Holiday)"
    Else
        strWE = strWE & Chr(10) & "- " & ArrKey(i) & " (" & WeekdayName(Weekday(ArrKey(i))) & ")"
    End If
    Next
    'MsgBox "Request successfully completed with following messages:" & vbCrLf & vbCrLf & "Entry denied for following date as they fall either on weekend or on holiday." & strWE, vbInformation + vbOKOnly, "Business Research Center"
    Range("A17").Value = "Request successfully completed with following messages:" & Chr(10) & Chr(10) & "Entry denied for following date as they fall either on weekend or on holiday." & strWE
    Else
    'MsgBox "Request successfully completed with following messages:" & vbCrLf & vbCrLf & "Entries updated.", vbInformation + vbOKOnly, "Business Research Center"
    Range("A17").Value = "Request successfully completed with following messages:" & Chr(10) & Chr(10) & "Entries updated."
    End If
    Range("B5").Select
Sheets("Resource Scheduler").Image1.Visible = False
End If
End Function
 
Function ShowReport()
Dim StrCntR As String
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Resource Availability").Image1.Visible = True
iState = False
tDate = Date
'splMsg = ""
sDate = Sheets("Resource Availability").Range("B5").Value
eDate = Sheets("Resource Availability").Range("D5").Value
 
If eDate - sDate > 5 Then
ActiveWindow.DisplayHorizontalScrollBar = True
Else
ActiveWindow.DisplayHorizontalScrollBar = False
End If
 
If eDate - sDate > 254 Then
MsgBox "MS Excel cannot show report for more than 254 days. Please adjust your start or end date.", vbApplicationModal + vbOKOnly, "BRC Scheduler"
End
End If
 
xDate = "8/28/06"
ArrTmpA = Split(Sheets("Resource Scheduler").Label8.Caption, ": ")
intCnt = ArrTmpA(1)
strUser = Left(Sheets("Resource Scheduler").TextBox1.Text, InStr(Sheets("Resource Scheduler").TextBox1.Text, " ") - 1)
 
If sDate - xDate < 0 Or eDate - xDate < 0 Then
MsgBox "No report is available for period before Aug 28, 2006. Please select date again.", vbExclamation + vbOKOnly, "Business Research Center"
End
End If
 
 
If intCnt > 25 Then
ActiveWindow.DisplayVerticalScrollBar = True
Else
ActiveWindow.DisplayVerticalScrollBar = False
End If
 
Sheets("Resource Availability").Unprotect = True
 
'For j = 0 To 25
    Sheets("Resource Availability").Range("B12:B" & intCnt + 12).EntireRow.Delete
'Next
 
'DoFormat
'If sDate - Date < 0 Then
'MsgBox "Sorry! You cannot change past entries.", vbExclamation + vbOKOnly, "Business Research Center"
'End
'End If
 
Application.StatusBar = "Accessing master file... Please wait."
Application.ScreenUpdating = False
 
'ChDir "\\ushyd0041\kms\Business Research Center\Common BRC Folder\BRC Time track"
DefFileVars
Workbooks.Open Filename:=FilePath, Password:=FilePassword, writerespassword:=FileModifyPassword
 
ActiveWorkbook.Sheets("Check").Select
 
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value <> Date Then
ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value = Date
ActiveWorkbook.SaveCopyAs Filename:=BackUPFilePath & ActiveWorkbook.Name
End If
 
Select Case WeekdayName(Weekday(sDate))
Case "Sunday"
sDate = sDate + 1
'splMsg = splMsg & "Start date set to " & Format(sDate, "MMM DD") & " as " & Format(sDate - 1, "MMM DD") & " is Sunday." & vbCrLf
Case "Saturday"
sDate = sDate + 2
'splMsg = splMsg & "Start date set to " & Format(sDate, "MMM DD") & " as " & Format(sDate - 2, "MMM DD") & " is Saturday." & vbCrLf
End Select
 
Select Case WeekdayName(Weekday(eDate))
Case "Sunday"
eDate = eDate - 2
'splMsg = splMsg & "End date set to " & Format(eDate, "MMM DD") & " as " & Format(eDate + 2, "MMM DD") & " is Sunday." & vbCrLf
Case "Saturday"
eDate = eDate - 1
'splMsg = splMsg & "End date set to " & Format(eDate, "MMM DD") & " as " & Format(eDate + 1, "MMM DD") & " is Saturday." & vbCrLf
End Select
 
'**********************************************************************
' UNCOMMENT FOLLOWING LINES IF DATABASE BREADTH EXCEEDS 255 OR IN CASE
' OF ANY ERROR ARISING OUT OF MISREPRESENTATION OF DATE
'**********************************************************************
'RSTRTA:
'i = 0
 
'Do While ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, i).Value <> sDate
'i = i + 1
'If i > 250 Then
'sDate = sDate + 1
'GoTo RSTRTA
'End If
'Loop
 
'RSTRTB:
'j = 0
 
'Do While ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, j).Value <> eDate
'j = j + 1
'If j > 250 Then
'eDate = eDate - 1
'GoTo RSTRTB
'End If
'Loop
'**********************************************************************
' COMMENT FOLLOWING LINES IF DATABASE BREADTH EXCEEDS 255 OR IN CASE
' OF ANY ERROR ARISING OUT OF MISREPRESENTATION OF DATE
'**********************************************************************
 
i = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
j = eDate - xDate + 1 - (((eDate - xDate) - ((eDate - xDate) Mod 7))) / 7
 
'**********************************************************************
' UNCOMMENT FOLLOWING LINES IF DATABASE BREADTH EXCEEDS 255 OR IN CASE
' OF ANY ERROR ARISING OUT OF MISREPRESENTATION OF DATE
'**********************************************************************
 
m = 0
    For l = 0 To intCnt - 1
    ArrRes(l, m) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, l).Value
    Next
m = m + 1
For k = i To j
    l = 0
    For l = 0 To intCnt - 1
    ArrRes(l, m) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, l).Value
    Next
m = m + 1
Next
    ActiveWindow.Close True
    Application.ScreenUpdating = True
    Application.StatusBar = False
            
            hwPG = m - 1
            If hwPG Mod 5 > 0 Then
            hwPG = Int(hwPG / 5) + 1
            Else
            hwPG = Int(hwPG / 5)
            End If
            Sheets("Resource Availability").Range("G5").Value = hwPG & " Pages"
            
Sheets("Resource Availability").Range("B12").Select
For i = 0 To m - 1
    For j = 0 To intCnt
            
            If j < 2 And ActiveCell.Offset(j, i).Value <> "-" Then
            ActiveCell.Offset(j, i).Font.Size = 8
            ActiveCell.Offset(j, i).Interior.ColorIndex = 55
            ActiveCell.Offset(j, i).Interior.Pattern = xlSolid
            ActiveCell.Offset(j, i).Font.ColorIndex = 2
            ActiveCell.Offset(j, i).Font.Bold = True
            ActiveCell.Offset(j, i).HorizontalAlignment = xlCenter
            ActiveCell.Offset(j, i).VerticalAlignment = xlBottom
            'ActiveCell.Offset(j, i).WrapText = False
            ActiveCell.Offset(j, i).Orientation = 0
            'ActiveCell.Offset(j, i).AddIndent = False
            ActiveCell.Offset(j, i).IndentLevel = 0
            'ActiveCell.Offset(j, i).ShrinkToFit = False
            ActiveCell.Offset(j, i).ReadingOrder = xlContext
            'ActiveCell.Offset(j, i).MergeCells = False
            ElseIf ActiveCell.Offset(j, i).Value <> "-" Then
            ActiveCell.Offset(j, i).Font.Size = 8
            ActiveCell.Offset(j, i).Interior.ColorIndex = 36
            ActiveCell.Offset(j, i).Interior.Pattern = xlSolid
            'ActiveCell.Offset(j, i).Borders(xlDiagonalDown).LineStyle = xlNone
            'ActiveCell.Offset(j, i).Borders(xlDiagonalUp).LineStyle = xlNone
            With ActiveCell.Offset(j, i).Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            End With
            With ActiveCell.Offset(j, i).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            End With
            With ActiveCell.Offset(j, i).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            End With
            With ActiveCell.Offset(j, i).Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
            End With
            ActiveCell.Offset(j, i).Font.Size = 8
            If i = 0 Then ActiveCell.Offset(j, i).Font.Bold = True
            End If
        
            If InStr(LCase(ArrRes(0, i)), "weekend") > 0 Or InStr(LCase(ArrRes(0, i)), "holiday") > 0 Then
            ActiveCell.Offset(0, i).Value = ArrRes(0, i)
            ActiveCell.Offset(j, i).Interior.Color = RGB(155, 0, 0)
            'ActiveCell.Offset(j, i).Font.Bold = True
            'ActiveCell.Offset(j, i).Font.Size = 7
            'ActiveCell.Offset(j, i).Font.Color = RGB(255, 255, 255)
            '    For m = 1 To 25
            '        ActiveCell.Offset(j + m, i).Interior.Color = RGB(155, 0, 0)
            '        ActiveCell.Offset(j + m, i).Font.Bold = True
            '        ActiveCell.Offset(j + m, i).Font.Size = 7
            '        ActiveCell.Offset(j + m, i).Font.Color = RGB(255, 255, 255)
            '        'ActiveCell.Offset(j + m, i).Value = "-"
            '    Next
            Else
            'If ActiveCell.Offset(j, 0).Value <> "" Then
            '    With ActiveCell.Offset(j, -1)
            '    .Value = "IM"
            '    .Font.Size = 8
            '    .Font.Bold = True
            '    .HorizontalAlignment = xlCenter
            '    .Font.ColorIndex = 9
            '    .AddComment
            '    .Comment.Visible = False
            '    .Comment.Text Text:="sacbhatia"
            '    End With
            'End If
            ActiveCell.Offset(j, -1).Locked = False
            ActiveCell.Offset(j, i).Locked = False
            If Left(ArrRes(j, i), 3) = "PTO" Then
                Dim strHalfPTOProj As String
                If InStr(ArrRes(j, i), "++") > 0 Then
                strHalfPTOProj = Right(ArrRes(j, i), Len(ArrRes(j, i)) - InStr(ArrRes(j, i), "++") - 1)
                ArrRes(j, i) = Left(ArrRes(j, i), InStr(ArrRes(j, i), "++") - 1)
                StrCntR = " [" & Right(ArrRes(j, i), 1) & "]; Other Half: " & strHalfPTOProj
                Else
                StrCntR = " [" & Right(ArrRes(j, i), 1) & "]"
                If Right(ArrRes(j, i), 1) = "" Or IsNumeric(Right(ArrRes(j, i), 1)) Then StrCntR = " [F]"
                End If
                'If InStr(Sheets("Resource Scheduler").TextBox1.Text, "Admin") > 0 Then
                'Else
                'StrCntR = ""
                'End If
            Select Case Mid(ArrRes(j, i), 6, 8)
            Case "Rejected"
                If strUser = ArrRes(j, 0) Then
                    ActiveCell.Offset(j, i).Interior.ColorIndex = 3
                    ArrRes(j, i) = "PTO (Denied)" & StrCntR
                Else
                    ArrRes(j, i) = "" '& StrCntR
                End If
            Case "Pending*"
            ActiveCell.Offset(j, i).Interior.ColorIndex = 44
            ArrRes(j, i) = "PTO (Request Pending)" & StrCntR
            Case Else
            'ActiveCell.Offset(j, i).Interior.ColorIndex = 33
                ActiveCell.Offset(j, i).Interior.ColorIndex = 33 ' 12
                'ActiveCell.Offset(j, i).Font.ColorIndex = 2
            ArrRes(j, i) = "PTO (Approved)" & StrCntR
            End Select
            End If
            ActiveCell.Offset(j, i).Value = ArrRes(j, i)
                If InStr(LCase(ArrRes(j, i)), "training") > 0 Then ActiveCell.Offset(j, i).Interior.ColorIndex = 12: ActiveCell.Offset(j, i).Font.ColorIndex = 2 '39
                If InStr(LCase(ArrRes(j, i)), "available") > 0 Then ActiveCell.Offset(j, i).Interior.ColorIndex = 38
            End If
     ' Set Print Area
            'cntPG = cntPG + 1
     Next
Next
Sheets("Resource Availability").Image1.Visible = False
Sheets("Resource Availability").Protect = True
'If splMsg <> "" Then
'ThisWorkbook.Sheets("Resource Availability").Label4.Caption = splMsg & vbCrLf & vbCrLf & "...Click here to close."
'ThisWorkbook.Sheets("Resource Availability").Label4.AutoSize = True
'ThisWorkbook.Sheets("Resource Availability").Label4.Visible = True
'End If
Application.ScreenUpdating = True
End Function
 
Sub BRCPrint()
'
' BRCPrint Macro
' Macro recorded 9/8/2006 by Business Research Center
'
'
Dim abbPG As String
cntPG() = Split(Range("G5").Value, " ")
 
Select Case cntPG(0)
Case 1
abbPG = "G"
Case 2
abbPG = "L"
Case 3
abbPG = "Q"
Case 4
abbPG = "V"
Case 5
abbPG = "AA"
Case 6
abbPG = "AF"
Case 7
abbPG = "AK"
Case 8
abbPG = "AP"
Case 9
abbPG = "AU"
Case 10
abbPG = "AZ"
Case Else
abbPG = "G"
End Select
    
    
    'ActiveWindow.SmallScroll Down:=-9
    ActiveSheet.PageSetup.PrintArea = "$B$9:$" & abbPG & "$37"
    With ActiveSheet.PageSetup
        .PrintTitleColumns = "$B:$B"
        .LeftHeader = "BRC Scheduler Report"
        .RightHeader = "&D"
        .RightFooter = "&P"
        .PrintHeadings = False
        .PrintGridlines = False
        .Orientation = xlLandscape
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub
 
Public Function CheckRights() As Boolean
Dim arrTemp() As String
Dim strTemp As String
 
arrTemp = Split(Sheets("Resource Scheduler").TextBox1.Text, " ")
strTemp = arrTemp(UBound(arrTemp))
 
If strTemp = "(Admin)" Or strTemp = "*" Then
    CheckRights = True
Else
    CheckRights = False
End If
End Function
 
Sub MailDefAppoint(ByVal strTO As String, ByVal strSub As String, ByVal strBody As String, ByVal SheetNm As String, ByVal sDate As Date, ByVal eDate As Date, ByVal PTOFHStatus As String)
Dim objOL As New Outlook.Application
Dim objMail As AppointmentItem
Application.ScreenUpdating = False
On Error Resume Next
    Set objOL = GetObject(, "Outlook.Application")
 
    If Err.Number = 429 Then
        Set objOL = CreateObject("Outlook.application")
    End If
 
    On Error GoTo 0
 
'Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olAppointmentItem)
    objMail.MeetingStatus = Outlook.OlMeetingStatus.olMeeting
    
    Dim mCnt As Integer
    Dim ArrmCnt() As String
    
    ArrmCnt = Split(strTO, ";")
    
    For mCnt = 0 To UBound(ArrmCnt)
    objMail.Recipients.Add ArrmCnt(mCnt)
    Next
    
    'objMail.Type = olTo
    objMail.Subject = strSub
    objMail.Body = strBody
    objMail.Start = sDate & " " & "11:00 AM"
    objMail.End = eDate & " " & "8:00 PM"
    objMail.Send
Set objMail = Nothing
Set objOL = Nothing
ActiveWorkbook.Sheets(SheetNm).Activate
Application.ScreenUpdating = True
End Sub
 
Sub MailDef(ByVal strTO As String, ByVal strSub As String, ByVal strBody As String, ByVal SheetNm As String)
Dim objOL As New Outlook.Application
Dim objMail As MailItem
Application.ScreenUpdating = False
On Error Resume Next
    Set objOL = GetObject(, "Outlook.Application")
 
    If Err.Number = 429 Then
        Set objOL = CreateObject("Outlook.application")
    End If
 
    On Error GoTo 0
 
'Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olMailItem)
    
    objMail.To = strTO
    objMail.Subject = strSub
    objMail.Body = strBody
    objMail.Send
Set objMail = Nothing
Set objOL = Nothing
ActiveWorkbook.Sheets(SheetNm).Activate
Application.ScreenUpdating = True
End Sub
 
Sub CheckDefault()
strTemp2 = ""
sDate = Date
ArrTmpA = Split(Sheets("Resource Scheduler").Label8.Caption, ": ")
intCnt = ArrTmpA(1) + 2
 
    Application.ScreenUpdating = False
 
DefFileVars
Workbooks.Open Filename:=FilePath, Password:=FilePassword, writerespassword:=FileModifyPassword
 
ActiveWorkbook.Sheets("Check").Select
 
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value <> Date Then
ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value = Date
ActiveWorkbook.SaveCopyAs Filename:=BackUPFilePath & ActiveWorkbook.Name
End If
 
Select Case WeekdayName(Weekday(sDate))
Case "Sunday"
ActiveWorkbook.Close True
End
Case "Saturday"
ActiveWorkbook.Close True
End
End Select
 
 
Do While ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(i, 0).Value <> sDate
i = i + 1
Loop
 
    For l = 0 To intCnt - 1
    ArrResMail(l, 0) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, l).Value
 '   MsgBox ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(l, 0).Value
    Next
    
    For l = 0 To intCnt - 1
    ArrResMail(l, 1) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(i, l).Value
 '   MsgBox ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(l, i).Value
    Next
 
ActiveWorkbook.Close True
    Application.ScreenUpdating = True
            
        For p = 0 To UBound(arrTemp) - 1
            If ArrResMail(p + 2, 1) = "" And Left(arrTemp(p), InStr(arrTemp(p), " ") - 1) = ArrResMail(p + 2, 0) Then
            strTemp2 = arrMail(p) & "@deloitte.com; " & strTemp2
            strDef = "  - " & arrTemp(p) & Chr(10) & strDef
            End If
        Next
        
    If InStr(strTemp2, "@") > 1 Then
    If MsgBox("Following resources have not updated their status in BRC Scheduler 2006 for " & Format(Date, "MMM DD, YY") & ":" & _
    vbCrLf & strDef & vbCrLf & _
    "You have admin rights to send notification mail to them. Send now?", vbYesNo + vbExclamation, "BRC Scheduler") = vbYes Then MailDef strTemp2, "Automated Mail Response", Chr(10) & "This is an automated message from " & Format(Range("A1").Value, "$ #,###.#0") & ". " & Chr(10) & Chr(10) & _
    "Admin system has detected that you have not updated your availability status. Please update it on priority." & Chr(10) & Chr(10) & _
    "Please contact your counselor if you are unable to access BRC Scheduler." & Chr(10) & Chr(10) & _
    "BRC Mailer", "Resource Scheduler"
    End If
    
End Sub
 
Sub ptoUpdate()
Dim xMon As String
Dim ByMon As Boolean
strTemp2 = ""
 
If Sheets("PTO Planner").ComboBox1.Value = "" Then Sheets("PTO Planner").ComboBox1.Value = Format(Date, "MMM YYYY")
xMon = Sheets("PTO Planner").ComboBox1.Value
ByMon = Sheets("PTO Planner").OptionButton1.Value
xDate = CDate("08/28/2006")
 
ArrTmpA = Split(Sheets("Resource Scheduler").Label8.Caption, ": ")
intCnt = ArrTmpA(1) + 2
 
strUser = Sheets("Resource Scheduler").TextBox1.Text
resName = Split(strUser, " ")
prjName = Sheets("Resource Scheduler").TextBox2.Text
 
If ByMon Then
sDate = CDate("01 January " & Year(CDate("01 " & xMon)))
eDate = CDate("31 December " & Year(CDate("01 " & xMon)))
If Year(CDate("01 " & xMon)) = 2006 Then sDate = CDate("28 August " & Year(CDate("01 " & xMon)))
Else
sDate = CDate("01 " & xMon)
eDate = sDate + Day(DateSerial(Year(CDate("1 " & xMon)), Month(CDate("1 " & xMon)) + 1, 0)) - 1
End If
 
m = 0
p = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
j = eDate - xDate + 1 - (((eDate - xDate) - ((eDate - xDate) Mod 7))) / 7
If Weekday(eDate, vbSaturday) < 3 Then j = j - 1
 
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Value = ""
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.Italic = False
ActiveWorkbook.Sheets("PTO Planner").Range("B13:I3000").Font.Size = 10
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.ColorIndex = 2
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.Bold = True
ActiveWorkbook.Sheets("PTO Planner").Range("B13:I3000").Offset(i, 3).HorizontalAlignment = xlLeft
 
Application.StatusBar = "Accessing master file... Please wait."
Application.ScreenUpdating = False
 
'ChDir "\\ushyd0041\kms\Business Research Center\Common BRC Folder\BRC Time track"
DefFileVars
Workbooks.Open Filename:=FilePath, Password:=FilePassword, writerespassword:=FileModifyPassword
ActiveWorkbook.Sheets("Check").Select
 
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value <> Date Then
ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value = Date
ActiveWorkbook.SaveCopyAs Filename:=BackUPFilePath & ActiveWorkbook.Name
End If
 
For i = 2 To intCnt + 1
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, i).Value = resName(0) Then m = i
Next
 
n = -1
For k = p To j
        If Left(ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, m).Value, 3) = "PTO" Then
                n = n + 1
                ArrDate(n) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, 0).Value
                ArrPTO(n) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, m).Value
        End If
Next
 
ActiveWorkbook.Close True
Application.ScreenUpdating = True
Application.StatusBar = False
 
Dim cntPTOMinus As Double
 
cntPTOMinus = n
 
For i = 0 To n
Range("B13").Offset(i, 0).Value = Mid(ArrPTO(i), 16, 2)
Range("B13").Offset(i, 3).Value = Format(ArrDate(i), "DD MMM YY")
Range("B13").Offset(i, 5).Value = PTO_Status(CDate(ArrDate(i)))
Range("B13").Offset(i, 7).Value = Mid(ArrPTO(i), InStr(ArrPTO(i), "//") + 2, 8)
Range("B13").Offset(i, 9).Value = Mid(ArrPTO(i), 20, 1)
If Mid(ArrPTO(i), 20, 1) = "" Then Range("B13").Offset(i, 9).Value = "F"
If Mid(ArrPTO(i), 20, 1) = "H" Then cntPTOMinus = cntPTOMinus - 0.5
Next
 
If n = -1 Then
Range("B13").Offset(n + 1, 0).Value = "No PTOs can be located for you in " & xMon
Else
Range("B13").Offset(n + 2, 0).Value = "* - Requires approval by teamlead."
Range("B13").Offset(n + 2, 0).Font.Size = 8
Range("B13").Offset(n + 2, 0).Font.Italic = True
Range("B13").Offset(n + 1, 0).Value = "Total PTOs: " & cntPTOMinus + 1
Range("B13").Offset(n + 1, 0).Font.Size = 8
End If
End Sub
 
Function PTO_Status(ByVal oDate As Date) As String
Select Case Date - oDate
Case Is > 0
PTO_Status = "Taken"
Case Is < 0
PTO_Status = "Unavailed"
Case Else
PTO_Status = "Today on PTO"
End Select
End Function
 
Sub AdminPTOUpdate()
Dim xMon As String
Dim ByMon As Boolean
 
xMon = Sheets("PTO Planner").ComboBox1.Value
ByMon = Sheets("PTO Planner").OptionButton1.Value
xDate = CDate("08/28/2006")
ArrTmpA = Split(Sheets("Resource Scheduler").Label8.Caption, ": ")
intCnt = ArrTmpA(1) + 2
 
strTemp = ""
For i = 13 To 300
If Len(Sheets("PTO Planner").Range("AF" & i).Value) > 3 And Len(Sheets("PTO Planner").Range("I" & i).Value) > 3 And InStr(Sheets("PTO Planner").Range("AF" & i).Value, Sheets("PTO Planner").Range("I" & i).Value) < 1 Then
Sheets("PTO Planner").Range("AF" & i).Value = Replace(Sheets("PTO Planner").Range("AF" & i).Value, "Pending*", Sheets("PTO Planner").Range("I" & i).Value)
Sheets("PTO Planner").Range("AF" & i).Value = Replace(Sheets("PTO Planner").Range("AF" & i).Value, "Rejected", Sheets("PTO Planner").Range("I" & i).Value)
strTemp = Sheets("PTO Planner").Range("AF" & i).Value & "/*\" & strTemp
Sheets("PTO Planner").Range("AF" & i).Value = ""
End If
Next
'--------------------------------------------------------------------------------------
'**************************************************************************************
If strTemp = "" Or xMon = "" Then GoTo JUSUPD
arrTemp = Split(strTemp, "/*\")
 
Application.StatusBar = "Accessing master file... Please wait."
Application.ScreenUpdating = False
 
 
DefFileVars
Workbooks.Open Filename:=FilePath, Password:=FilePassword, writerespassword:=FileModifyPassword
        
ActiveWorkbook.Sheets("Check").Select
 
For i = 0 To UBound(arrTemp) - 1
ArrTmpA = Split(arrTemp(i), "/*/")
sDate = CDate(ArrTmpA(1))
p = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
prjName = ArrTmpA(2)
 
'If sDate - Date < 0 Then
'MsgBox "Sorry! You cannot change past entries.", vbExclamation + vbOKOnly, "Business Research Center"
'End
'End If
        
For j = 2 To intCnt + 1
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, j).Value = ArrTmpA(0) Then ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(p, j).Value = prjName
Next
 
'**************************************************************************************
'--------------------------------------------------------------------------------------
Next
 
AdminChkBRCStatus xMon, Day(DateSerial(Year(CDate("1 " & xMon)), Month(CDate("1 " & xMon)) + 1, 0)), intCnt, ByMon
    
Sheets("PTO Planner").Range("N28").Value = "PTO Status updated for selected resources"
Sheets("PTO Planner").Image1.Visible = False
End
 
JUSUPD:
Macro1 Sheets("PTO Planner").ComboBox1.Value
End Sub
 
Sub Macro1(ByVal xMon As String)
Dim RowNum As Integer
 
RowNum = 15
ArrTmpA = Split(Sheets("Resource Scheduler").Label8.Caption, ": ")
intCnt = ArrTmpA(1) + 2
 
    Range("N" & RowNum).Select
    Range("N" & RowNum + 2 & ":T" & RowNum + 7).Value = ""
    Range("N" & RowNum + 2 & ":T" & RowNum + 7).Interior.ColorIndex = 49
    ActiveWorkbook.Sheets("PTO Planner").Range("AF13:AF3000").Value = ""
 
    ActiveCell.Range("A1:G1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    Selection.Interior.ColorIndex = 44
    Selection.Font.ColorIndex = 49
        With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
 
    Range("N" & RowNum + 1).Select
    
    ActiveCell.Range("A1:G7").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
    End With
    ActiveCell.Range("A1:B7").Select
    Selection.Font.ColorIndex = 48
    ActiveCell.Offset(0, 2).Range("A1:E7").Select
    Selection.Font.ColorIndex = 2
    ActiveCell.Offset(0, -2).Range("A1").Select
    ActiveCell.FormulaR1C1 = "S"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "M"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "T"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "W"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "T"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "F"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "S"
    ActiveCell.Offset(0, -5).Range("A1:A7").Select
    Selection.Font.ColorIndex = 2
    ActiveCell.Offset(0, 5).Range("A1:A7").Select
    Selection.Font.ColorIndex = 48
    ActiveCell.Offset(0, -6).Range("A1:G7").Select
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
    ActiveCell.Offset(1, 0).Range("A1").Select
 
Range("N" & RowNum).Value = xMon
Range("N" & RowNum + 2).Select
ChkBRCStatus xMon, Day(DateSerial(Year(CDate("1 " & xMon)), Month(CDate("1 " & xMon)) + 1, 0)), intCnt
m = 0
n = 0
For i = 1 To Day(DateSerial(Year(CDate("1 " & xMon)), Month(CDate("1 " & xMon)) + 1, 0))
p = 0
    For l = 0 To intCnt - 1
    If Sheets("PTO Planner").CheckBox1.Value Then
        If Left(ArrRes(l, n), 3) = "PTO" And InStr(ArrRes(l, n), "Approved") > 0 Then p = p + 1
    Else 'NEWLY ADDED LINE - JULY 12: "And InStr(LCase(ArrRes(l, n)), "rejected") < 1"
        If Left(ArrRes(l, n), 3) = "PTO" And InStr(LCase(ArrRes(l, n)), "rejected") < 1 Then p = p + 1
    End If
    If InStr(LCase(ArrRes(0, n)), "holiday") > 0 Then p = allowedPTOlimit * 100
    Next
 
    If Weekday(CDate(i & " " & xMon), vbSunday) = 1 And i > 0 Then
    If i > 1 Then m = m + 1
    n = n - 1
    End If
    n = n + 1
    ActiveCell.Offset(m, Weekday(CDate(i & " " & xMon), vbSunday) - 1).Value = i
 
    If Weekday(CDate(i & " " & xMon), vbSaturday) > 2 Then
    Select Case p
    Case Is < allowedPTOlimit - Int(allowedPTOlimit / 2)
        ActiveCell.Offset(m, Weekday(CDate(i & " " & xMon), vbSunday) - 1).Interior.ColorIndex = 10
    Case Is = allowedPTOlimit - Int(allowedPTOlimit / 2)
        ActiveCell.Offset(m, Weekday(CDate(i & " " & xMon), vbSunday) - 1).Interior.ColorIndex = 45
    Case Is = allowedPTOlimit * 100
        ActiveCell.Offset(m, Weekday(CDate(i & " " & xMon), vbSunday) - 1).Interior.ColorIndex = 54
    Case Else
        ActiveCell.Offset(m, Weekday(CDate(i & " " & xMon), vbSunday) - 1).Interior.ColorIndex = 9
    End Select
    End If
Next
Sheets("PTO Planner").Range("N28").Value = "PTO Status is updated for " & xMon & " in grid above"
End Sub
 
Sub ChkBRCStatus(ByVal yMon As String, ByVal LstDate As Integer, ByVal rCount As Integer)
On Error Resume Next
Dim tmpStatus As Boolean
Dim ByMon As Boolean
Dim xMon As String
 
ByMon = Sheets("PTO Planner").OptionButton1.Value
If Sheets("PTO Planner").ComboBox1.Value = "" Then Sheets("PTO Planner").ComboBox1.Value = Format(Date, "MMM YYYY")
xMon = Sheets("PTO Planner").ComboBox1.Value
 
If yMon = "" And Not ByMon Then End
 
tmpStatus = False
 
xDate = "8/28/06"
intCnt = rCount
 
sDate = CDate("01 " & yMon)
eDate = sDate + LstDate - 1
 
p = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
j = eDate - xDate + 1 - (((eDate - xDate) - ((eDate - xDate) Mod 7))) / 7
'If Weekday(sDate, vbSaturday) < 3 Then p = p + 1
If Weekday(eDate, vbSaturday) < 3 Then j = j - 1
 
Application.StatusBar = "Accessing master file... Please wait."
Application.ScreenUpdating = False
 
DefFileVars
Workbooks.Open Filename:=FilePath, Password:=FilePassword, writerespassword:=FileModifyPassword
ActiveWorkbook.Sheets("Check").Select
 
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value <> Date Then
ActiveWorkbook.Sheets("Resource Availability Sheet").Range("A1").Value = Date
ActiveWorkbook.SaveCopyAs Filename:=BackUPFilePath & ActiveWorkbook.Name
End If
 
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B1").Value <> "" Then
allowedPTOlimit = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B1").Value
Else
allowedPTOlimit = 2
End If
 
For k = p To j
    For l = 0 To rCount - 1
    ArrRes(l, k - p) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, l).Value
    Next
Next
 
If ByMon Then
sDate = CDate("01 January " & Year(CDate("01 " & yMon)))
eDate = CDate("31 December " & Year(CDate("01 " & yMon)))
If Year(CDate("01 " & yMon)) = 2006 Then sDate = CDate("28 August " & Year(CDate("01 " & yMon)))
p = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
j = eDate - xDate + 1 - (((eDate - xDate) - ((eDate - xDate) Mod 7))) / 7
'If Weekday(sDate, vbSaturday) < 3 Then p = p + 1
If Weekday(eDate, vbSaturday) < 3 Then j = j - 1
End If
 
If isAdmin Then
For i = 0 To intCnt - 1
For k = 0 To j - p
                ArrPTOAdmin(i, k) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, i + 2).Value & "/*/" & _
                ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k + p, 0).Value & "/*/" & _
                ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k + p, i + 2).Value
    Next
Next
ActiveWorkbook.Close True
    Application.ScreenUpdating = True
    Application.StatusBar = False
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Value = ""
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Validation.Delete
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.ColorIndex = 2
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.FontStyle = "Arial"
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.Size = 9
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.Bold = True
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.Italic = False
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Offset(i, 3).HorizontalAlignment = xlLeft
ActiveWorkbook.Sheets("PTO Planner").Range("K13:K3000").HorizontalAlignment = xlCenter
    With ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
 
Dim n As Double
 
m = -1
Range("B13").Value = "No PTOs can be located in " & yMon
For i = 0 To intCnt - 1
tmpStatus = True
n = 0
For k = 0 To j - p
ArrTmpA = Split(ArrPTOAdmin(i, k), "/*/")
       If Left(ArrTmpA(2), 3) = "PTO" Then
            n = n + 1
            If InStr(ArrTmpA(2), "//H") > 1 Then n = n - 0.5
            If tmpStatus Then
                m = m + 1
                With Range("B13").Offset(m, 0).Range("A1:J1")
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlEdgeLeft).LineStyle = xlNone
                    .Borders(xlEdgeBottom).LineStyle = xlNone
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).Weight = xlThin
                    .Borders(xlEdgeTop).ColorIndex = 2
                End With
            End If
            If tmpStatus Then Range("B13").Offset(m, 0).Value = ArrTmpA(0)
            Range("B13").Offset(m, 3).Value = Format(ArrTmpA(1), "DD MMM YY")
            Range("B13").Offset(m, 5).Value = PTO_Status(CDate(ArrTmpA(1)))
            Range("B13").Offset(m, 7).Value = Mid(ArrTmpA(2), InStr(ArrTmpA(2), "//") + 2, 8)
            Range("B13").Offset(m, 8).Value = Mid(ArrTmpA(2), 16, 2)
            Range("B13").Offset(m, 8).HorizontalAlignment = xlRight
            Range("B13").Offset(m, 9).Value = Mid(ArrTmpA(2), 20, 1)
            If Mid(ArrTmpA(2), 20, 1) = "" Then Range("B13").Offset(m, 9).Value = "F"
 
            If Left(Range("B13").Offset(m, 7).Value, 7) = "Pending" Or Left(Range("B13").Offset(m, 7).Value, 7) = "Rejecte" Then
            'If CDate(Range("B13").Offset(m, 3).Value) - Date > 0 Then
                    With Range("B13").Offset(m, 7).Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=$AH$14:$AH$15"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                    End With
                Range("B13").Offset(m, 30).Value = ArrPTOAdmin(i, k)
            End If
            m = m + 1
            tmpStatus = False
      End If
    Next
    If n > 0 Then
    Range("B13").Offset(m, 0).Value = "PTOs Requested: " & n
    Range("B13").Offset(m, 0).Font.FontStyle = "Tahoma"
    Range("B13").Offset(m, 0).Font.Size = 8
    End If
Next
Else
strTemp2 = ""
strUser = Sheets("Resource Scheduler").TextBox1.Text
resName = Split(strUser, " ")
prjName = Sheets("Resource Scheduler").TextBox2.Text
 
For i = 0 To intCnt - 1
If ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, i + 2).Value = resName(0) Then m = i + 2
Next
n = -1
For k = p To j
        If Left(ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, m).Value, 3) = "PTO" Then
                n = n + 1
                ArrDate(n) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, 0).Value
                ArrPTO(n) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, m).Value
        End If
Next
ActiveWorkbook.Close True
    Application.ScreenUpdating = True
    Application.StatusBar = False
m = 0
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Value = ""
ActiveWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.Italic = False
ActiveWorkbook.Sheets("PTO Planner").Range("B13:I3000").Font.Size = 10
ActiveWorkbook.Sheets("PTO Planner").Range("B13:I3000").Font.ColorIndex = 2
ActiveWorkbook.Sheets("PTO Planner").Range("B13:I3000").Font.Bold = True
ActiveWorkbook.Sheets("PTO Planner").Range("B13:I3000").Offset(i, 3).HorizontalAlignment = xlLeft
 
For i = 0 To n
Range("B13").Offset(i, 0).Value = Mid(ArrPTO(i), 16, 2)
Range("B13").Offset(i, 3).Value = Format(ArrDate(i), "DD MMM YY")
Range("B13").Offset(i, 5).Value = PTO_Status(CDate(ArrDate(i)))
Range("B13").Offset(i, 7).Value = Mid(ArrPTO(i), InStr(ArrPTO(i), "//") + 2, 8)
Range("B13").Offset(i, 9).Value = Mid(ArrPTO(i), 20, 1)
If Mid(ArrPTO(i), 20, 1) = "" Then Range("B13").Offset(i, 9).Value = "F"
Next
 
If n = -1 Then
Range("B13").Offset(n + 1, 0).Value = "No PTOs can be located for you in " & xMon
Else
Range("B13").Offset(n + 2, 0).Value = "* - Requires approval by teamlead."
Range("B13").Offset(n + 2, 0).Font.Size = 8
Range("B13").Offset(n + 2, 0).Font.Italic = True
Range("B13").Offset(n + 1, 0).Value = "Total PTOs: " & n + 1
Range("B13").Offset(n + 1, 0).Font.Size = 8
End If
 
End If
End Sub
 
Sub AdminChkBRCStatus(ByVal yMon As String, ByVal LstDate As Integer, ByVal rCount As Integer, Optional ByVal ByMon As Boolean)
'On Error Resume Next
Dim tmpStatus As Boolean
 
tmpStatus = False
sDate = CDate("01 " & yMon)
eDate = sDate + LstDate - 1
 
xDate = "8/28/06"
intCnt = rCount
 
p = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
j = eDate - xDate + 1 - (((eDate - xDate) - ((eDate - xDate) Mod 7))) / 7
 
'If Weekday(sDate, vbSaturday) < 3 Then p = p + 1
If Weekday(eDate, vbSaturday) < 3 Then j = j - 1
 
m = 1
For k = p To j
    l = 0
    For l = 0 To rCount - 1
    ArrRes(l, m) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k, l).Value
    Next
m = m + 1
Next
 
If isAdmin Then
If ByMon Then
sDate = CDate("01 January " & Year(CDate("01 " & yMon)))
eDate = CDate("31 December " & Year(CDate("01 " & yMon)))
If Year(CDate("01 " & yMon)) = 2006 Then sDate = CDate("28 August " & Year(CDate("01 " & yMon)))
p = sDate - xDate + 1 - (((sDate - xDate) - ((sDate - xDate) Mod 7))) / 7
j = eDate - xDate + 1 - (((eDate - xDate) - ((eDate - xDate) Mod 7))) / 7
End If
 
For i = 0 To intCnt - 1
For k = 0 To j - p
                ArrPTOAdmin(i, k) = ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(0, i + 2).Value & "/*/" & _
                ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k + p, 0).Value & "/*/" & _
                ActiveWorkbook.Sheets("Resource Availability Sheet").Range("B3").Offset(k + p, i + 2).Value
    Next
Next
End If
 
    ActiveWindow.Close True
    Application.ScreenUpdating = True
    Application.StatusBar = False
 
 
If isAdmin Then
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Value = ""
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Validation.Delete
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.ColorIndex = 2
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.FontStyle = "Arial"
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.Size = 9
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.Bold = True
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Font.Italic = False
ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000").Offset(i, 3).HorizontalAlignment = xlLeft
    With ActiveWorkbook.Sheets("PTO Planner").Range("B13:J3000")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
 
m = -1
Range("B13").Value = "No PTOs can be located in " & yMon
For i = 0 To intCnt - 1
tmpStatus = True
n = 0
For k = 0 To j - p
ArrTmpA = Split(ArrPTOAdmin(i, k), "/*/")
       If Left(ArrTmpA(2), 3) = "PTO" Then
            n = n + 1
            If tmpStatus Then
                m = m + 1
                With Range("B13").Offset(m, 0).Range("A1:I1")
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlEdgeLeft).LineStyle = xlNone
                    .Borders(xlEdgeBottom).LineStyle = xlNone
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).Weight = xlThin
                    .Borders(xlEdgeTop).ColorIndex = 2
                End With
            End If
            If tmpStatus Then Range("B13").Offset(m, 0).Value = ArrTmpA(0)
            Range("B13").Offset(m, 3).Value = Format(ArrTmpA(1), "DD MMM YY")
            Range("B13").Offset(m, 5).Value = PTO_Status(CDate(ArrTmpA(1)))
            Range("B13").Offset(m, 7).Value = Mid(ArrTmpA(2), InStr(ArrTmpA(2), "//") + 2, 8)
            Range("B13").Offset(m, 8).Value = Right(ArrTmpA(2), 2)
            Range("B13").Offset(m, 8).HorizontalAlignment = xlRight
            If Left(Range("B13").Offset(m, 7).Value, 7) = "Pending" Or Left(Range("B13").Offset(m, 7).Value, 7) = "Rejecte" Then
                    With Range("B13").Offset(m, 7).Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=$AH$14:$AH$15"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                    End With
                Range("B13").Offset(m, 30).Value = ArrPTOAdmin(i, k)
                End If
            m = m + 1
            tmpStatus = False
      End If
    Next
    If n > 0 Then
    Range("B13").Offset(m, 0).Value = "PTOs Requested: " & n
    Range("B13").Offset(m, 0).Font.FontStyle = "Tahoma"
    Range("B13").Offset(m, 0).Font.Size = 8
    End If
Next
End If
End Sub
 
Sub AfterUpdate()
MsgBox "Your BRC Scheduler has been updated.", vbOKOnly + vbApplicationModal, "BRC Updater"
End Sub
 
 
Sub CallOpen()
On Error Resume Next
Dim blnExists As Boolean
 
Application.StatusBar = "Loading BRC Scheduler and its components..."
 
blnExists = ToolbarExists
 
If blnExists = True Then
    RemoveToolbar
End If
 
    CreateToolbar
 
Application.StatusBar = "Preparing user-interface..."
 
    Sheets("PTO Planner").Range("C7").Value = Date
    Sheets("PTO Planner").Range("E7").Value = Date
 
Sheets("PTO Planner").ComboBox1.AddItem "Sep 2006"
Sheets("PTO Planner").ComboBox1.AddItem "Oct 2006"
Sheets("PTO Planner").ComboBox1.AddItem "Nov 2006"
Sheets("PTO Planner").ComboBox1.AddItem "Dec 2006"
Sheets("PTO Planner").ComboBox1.AddItem "Jan 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Feb 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Mar 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Apr 2007"
Sheets("PTO Planner").ComboBox1.AddItem "May 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Jun 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Jul 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Aug 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Sep 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Oct 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Nov 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Dec 2007"
Sheets("PTO Planner").ComboBox1.AddItem "Jan 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Feb 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Mar 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Apr 2008"
Sheets("PTO Planner").ComboBox1.AddItem "May 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Jun 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Jul 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Aug 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Sep 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Oct 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Nov 2008"
Sheets("PTO Planner").ComboBox1.AddItem "Dec 2008"
 
Application.StatusBar = "Verifying your log-in information..."
 
    Sheets("Resource Scheduler").Select
    strUser = GetUser
    Sheets("Resource Scheduler").TextBox1.Text = strUser
    
    Sheets("Resource Scheduler").Range("B8").Value = Date
    Sheets("Resource Scheduler").Range("B11").Value = Date
    Sheets("Resource Availability").Range("B5").Value = Date
    Sheets("Resource Availability").Range("D5").Value = Date
    Sheets("Resource Scheduler").Range("B5").Select
 
Application.StatusBar = "Loading personal settings for " & strUser & "..."
 
If isAdmin = True Then
    Sheets("Resource Scheduler").Range("B2").Value = "Please select resource"
    Sheets("Resource Scheduler").Range("B1").Value = "You can select resource to update entries"
    Sheets("Resource Scheduler").ComboBox1.Visible = True
    Sheets("Resource Scheduler").TextBox1.Visible = False
    'Sheets("Resource Scheduler").TextBox1.Text = Sheets("Resource Scheduler").ComboBox1.Value
    Sheets("PTO Planner").Range("B11").Value = "Resource"
    Sheets("PTO Planner").Range("J11").Value = "R#"
Sheets("Resource Scheduler").Range("A17").Value = "Welcome " & strUser & " (You have admin rights)"
Sheets("PTO Planner").Label3.Enabled = False
Sheets("PTO Planner").Label3.Visible = False
Sheets("PTO Planner").Range("A3:A9").EntireRow.Hidden = True
Sheets("PTO Planner").CommandButton1.Visible = False
Sheets("PTO Planner").CommandButton2.Visible = False
Sheets("PTO Planner").CommandButton3.Visible = False
Sheets("PTO Planner").Label1.Visible = False
Sheets("PTO Planner").TextBox1.Visible = False
'Sheets("PTO Planner").OptionButton1.Visible = True
'Sheets("PTO Planner").OptionButton2.Visible = True
'Sheets("PTO Planner").OptionButton1.Value = True
Else
    Sheets("Resource Scheduler").Range("B1").Value = ""
    Sheets("Resource Scheduler").Range("B2").Value = "You have logged in as"
    Sheets("Resource Scheduler").ComboBox1.Visible = False
    Sheets("Resource Scheduler").TextBox1.Visible = True
    Sheets("PTO Planner").Range("B11").Value = "Request #"
    Sheets("PTO Planner").Range("J11").Value = ""
Sheets("PTO Planner").Label3.Enabled = True
Sheets("PTO Planner").Label3.Visible = True
Sheets("PTO Planner").Label3.SpecialEffect = fmSpecialEffectRaised
Sheets("Resource Scheduler").Range("A17").Value = "Welcome " & strUser
'Sheets("PTO Planner").OptionButton1.Visible = False
'Sheets("PTO Planner").OptionButton2.Visible = False
End If
 
Sheets("Resource Scheduler").OpButton1.Value = True
Sheets("Resource Scheduler").TextBox2.Activate
Sheets("Resource Scheduler").Image1.Visible = False
Sheets("Resource Availability").Image1.Visible = False
Application.StatusBar = "Ready. You have logged in as " & Left(strUser, InStr(strUser, " (")) & "(" & Application.OrganizationName & ")"
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
 
Sub CallClose()
On Error Resume Next
 
Sheets("Resource Availability").Select
If Sheets("Resource Availability").CheckBox1.Value = True Then
'For j = 0 To 39
    Range("B12:B37").EntireRow.Delete
'Next
End If
Range("G5").Value = ""
Sheets("Resource Scheduler").Select
 
ThisWorkbook.Sheets("PTO Planner").Range("AF13:AF3000").Value = ""
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Value = ""
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Validation.Delete
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.ColorIndex = 2
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.FontStyle = "Arial"
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.Size = 9
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.Bold = True
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Font.Italic = False
ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000").Offset(i, 3).HorizontalAlignment = xlLeft
    With ThisWorkbook.Sheets("PTO Planner").Range("B13:K3000")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
ThisWorkbook.Sheets("PTO Planner").Range("N17:T22").Value = ""
ThisWorkbook.Sheets("PTO Planner").Range("N15").Value = ""
ThisWorkbook.Sheets("PTO Planner").Range("N28").Value = ""
ThisWorkbook.Sheets("PTO Planner").ComboBox1.Value = ""
ThisWorkbook.Sheets("PTO Planner").Range("N17:T22").Interior.ColorIndex = 49
Sheets("Resource Scheduler").TextBox1.Text = ""
Sheets("Resource Scheduler").TextBox2.Text = ""
Sheets("Resource Scheduler").ComboBox1.Text = ""
ThisWorkbook.Save
End Sub

Open in new window

Avatar of zorvek (Kevin Jones)
zorvek (Kevin Jones)
Flag of United States of America image
Are you developing on 2007 and are the user having the issue on 2003?

Kevin
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image
Looking for anything dubious the first thing I am suspiscious of is:

If Sheets("PTO Planner").opHalf.Value = True Then

AFAIK ophalf is not a valid construct in this respect  Can you explain what should be happening?

Chris
Avatar of kmscommsteam
kmscommsteam
Flag of United States of America image

ASKER

Hi Kevin,

Currently working on 2007. The users are also using 2007.

It used to work absolutely fine when we used 2003. Recently shifted to Vista and 2007, worked fine for few days, but now giving this error.
Avatar of zorvek (Kevin Jones)
zorvek (Kevin Jones)
Flag of United States of America image
The reason I asked is that you are referencing Outlook. When moving a workbook saved on a later version of Excel to an earlier version of Excel can cause issues with library references. But if all users are on Office 2007 then that is probably not the issue. I was not able to get a compile error on either 2003 or 2007.

Kevin
Avatar of Rory Archibald
Rory Archibald
Flag of United Kingdom of Great Britain and Northern Ireland image
One small off-topic point about the code. This line:
Global FilePath, FilePassword, FileModifyPassword, BackUPFilePath As String
only declares BackUPFilePath as a string; the others are all declared as variants since you didn't specify their type. The line should read:
Global FilePath As String, FilePassword As String, FileModifyPassword As String, BackUPFilePath As String

and similarly for some of the other declaration lines.
Regards,
Rory
Avatar of kmscommsteam
kmscommsteam
Flag of United States of America image

ASKER

Indeed. Some of our users didn't receive any error and the application loaded smoothly. But few of them faced this issue. I am surprised as to why only a few of them are facing this issue and not everyone. Can you please provide me with any solution to this? Is there any reference I should be adding to in this case?
Avatar of zorvek (Kevin Jones)
zorvek (Kevin Jones)
Flag of United States of America image
Can you tell us anything about the users who are experiencing the problem? Anything unusual or different about there systems?

Kevin
Avatar of kmscommsteam
kmscommsteam
Flag of United States of America image

ASKER

The users have similar softwares and pc configurations of their computers. so that's not the issue. Only concern can be what you have suggested, the reference to outlook library... can you please let me know which file should i add in the list to give that reference? thanks so much for the help..
Avatar of zorvek (Kevin Jones)
zorvek (Kevin Jones)
Flag of United States of America image
If your code compiles on your machine then you should already have the reference. Moving to machine with an earlier version of Outlook can create the problem but it is very difficult to resolve using code. What I do to get around this is use late binding. Below is a description of how to use late binding for Word.

There are advantages and disadvantages each to using early and late binding. Early binding provides a better coding environment by providing automatic lists of properties, methods, and constants but requires that the project reference the Word Object Library which can be problematic when operating on multiple platforms (such as moving from Excel 2002 to Excel 2000.) Late binding does not require a reference to a library but also does not provide automatic lists of properties, methods, and constants. Here is a technique for using both at the same time.

Build the code so that the project can be switched between early and late binding with a conditional compilation argument. To create a conditional compilation argument select the menu command Tools->VBAProject Properties. Enter the following in the Conditional Compilation Arguments text edit box:

   AuthoringWord = -1

Add the following module level declaration lines:

#If AuthoringWord Then
   Private mWordApplication As Word.Application
   Private mWordDocument As Word.Document
#Else
   Private mWordApplication As Object
   Private mWordDocument As Object
#End If

Add code to create a new Word application:

#If AuthoringWord Then
   Set mWordApplication = New Word.Application
#Else
   Set mWordApplication = CreateObject("Word.Application")
#End If

When referencing word constants in development mode (early binding or AuthoringWord = -1 and the Word object library is referenced) access Word constants as illustrated below.

   Placement:=Word.wdInLine

But when the basic functionality has been tested and the project is being switched to late binding, the constants must be converted to constant values as illustrated below.

   Placement:=2

or, better yet, add the set of Word constant declarations to a regular module and reference them as illustrated below.

   Placement:=wdInLine

Note that the reference without the "Word" qualifier is how constants are referenced in Word-generated macros.

Kevin
ASKER CERTIFIED SOLUTION
Avatar of zorvek (Kevin Jones)
zorvek (Kevin Jones)
Flag of United States of America image
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of kmscommsteam
kmscommsteam
Flag of United States of America image

ASKER

Sorry for logging in after a long time. Wasn't aware of the rules... will keep that in mind.
Thanks Zorvek!