SMFERNANDO
New Member
- Joined
- Apr 23, 2018
- Messages
- 2
Hello,
This is a excel macro used to allocate hours in a tool "Promise" using Internet Explorer. It works fine on my Laptop, but when i run the same macro on another machine. it gives error. "session expired." when i run the macro step by step using F8 till the page "http://promise.cross-tab.com/scheduler/index.html" and then when i play the macro it works. Below is the code.
Please help me.
Dim ie As Object
Sub Allocation()
Dim tdCollection As Object 'table that has the javascript attributes and contains the element I want to click
Dim cell As Object 'specific "clickable" cell in the table to test
Dim objElement As Object
Dim Elements As Object
Dim Element As Object
Dim lastRow As Long
Dim Lastcol As Long
Dim StartTime As Double
Dim MinutesElapsed As String
sDayName = Val(Format(Date, "dd"))
StartTime = Timer
Sheets("Sheet3").Select
lastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Lastcol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Application.ScreenUpdating = False
Shell "RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 8"
'U = Application.InputBox("Enter Username", "Username")
'P = Application.InputBox("Enter Password", "pwd")
U = "sebastin.fernando@cross-tab.com"
P = "sebi123"
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
apiShowWindow ie.hwnd, SW_MAXIMIZE
ie.Navigate "http://promise.cross-tab.com/"
Application.StatusBar = "Submitting"
' Wait while IE loading...
While ie.READYSTATE <> 4 Or ie.busy: DoEvents: Wend
' **********************************************************************
ie.document.getelementbyID("Username").Value = U
ie.document.getelementbyID("Password").Value = P
ie.document.getelementbyID("btnSignIn").Click
'**********************************************************************
' While ie.READYSTATE <> 4 Or ie.busy: DoEvents: Wend
delay 2
ie.Navigate "http://promise.cross-tab.com/schedule.html"
While ie.busy: DoEvents: Wend
For Z = 2 To Application.WorksheetFunction.CountA(Range("A:A"))
If Cells(Z, 7) <> "Done" Then
'delay 2
ie.Navigate "http://promise.cross-tab.com/scheduler/index.html"
' Wait while IE loading...
While ie.READYSTATE <> 4: DoEvents: Wend
delay 2
If Cells(Z, 9) = "Yes" Then
ie.document.getelementbyID("dhx_minical_icon").Click
ie.document.getelementsbyclassname("dhx_month_head")(Val(Format(Date, "dd"))).fireevent "*******", 1, 2
End If
ie.document.getelementsbyclassname("dhx_matrix_cell ")(0).fireevent "ondblclick", 1, 2
If InStr(Trim(LCase(ie.document.getelementsbyclassname("dhx_cal_ltext")(0).innertext)), Trim(LCase(Cells(Z, 1)))) = 0 Then
Cells(Z, 7) = "Programmer Not Available"
GoTo nextz
End If
Set Elements = ie.document.getelementsbytagname("Select")(0)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If Trim(LCase(txt)) = Trim(LCase(Cells(Z, 1))) Then
ie.document.getelementsbytagname("select")(0).Value = Va
ie.document.getelementsbytagname("select")(0).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
If InStr(Trim(LCase(ie.document.getelementsbyclassname("dhx_cal_ltext")(1).innertext)), Trim(LCase(Cells(Z, 2)))) = 0 Then
Cells(Z, 7) = "Project Not Available"
GoTo nextz
End If
Set Elements = ie.document.getelementsbytagname("Select")(1)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If Trim(LCase(txt)) = Trim(LCase(Cells(Z, 2))) Then
ie.document.getelementsbytagname("select")(1).Value = Va
ie.document.getelementsbytagname("select")(1).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
If InStr(Trim(LCase(ie.document.getelementsbyclassname("dhx_cal_ltext")(2).innertext)), Trim(LCase(Cells(Z, 3)))) = 0 Then
Cells(Z, 7) = "Add Programmer in the Project"
GoTo nextz
End If
Set Elements = ie.document.getelementsbytagname("Select")(2)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If InStr(Trim(LCase(txt)), Trim(LCase(Cells(Z, 3)))) > 0 Then
ie.document.getelementsbytagname("select")(2).Value = Va
ie.document.getelementsbytagname("select")(2).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
Set Elements = ie.document.getelementsbytagname("Select")(3)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If Trim(LCase(txt)) = Trim(LCase(Cells(Z, 4))) Then
ie.document.getelementsbytagname("select")(3).Value = Va
ie.document.getelementsbytagname("select")(3).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
ie.document.getelementsbytagname("input")(0).innertext = Cells(Z, 5).Value
ie.document.getelementsbytagname("textarea")(0).innertext = Cells(Z, 6).Value
ie.document.getelementsbyclassname("dhx_save_btn")(0).Click
Cells(Z, 7) = "Done"
Cells(Z, 8) = Date
'**********************************************************************
nextz:
Else
End If
Next Z
ie.Quit
Set ie = Nothing
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Allocation code ran successfully in " & MinutesElapsed & " HMS", vbInformation
Application.ScreenUpdating = True
End Sub
Private Sub delay(seconds As Long)
Dim endTime As Date
endTime = DateAdd("s", seconds, Now())
Do While Now() < endTime
DoEvents
Loop
End Sub
This is a excel macro used to allocate hours in a tool "Promise" using Internet Explorer. It works fine on my Laptop, but when i run the same macro on another machine. it gives error. "session expired." when i run the macro step by step using F8 till the page "http://promise.cross-tab.com/scheduler/index.html" and then when i play the macro it works. Below is the code.
Please help me.
Dim ie As Object
Sub Allocation()
Dim tdCollection As Object 'table that has the javascript attributes and contains the element I want to click
Dim cell As Object 'specific "clickable" cell in the table to test
Dim objElement As Object
Dim Elements As Object
Dim Element As Object
Dim lastRow As Long
Dim Lastcol As Long
Dim StartTime As Double
Dim MinutesElapsed As String
sDayName = Val(Format(Date, "dd"))
StartTime = Timer
Sheets("Sheet3").Select
lastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Lastcol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Application.ScreenUpdating = False
Shell "RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 8"
'U = Application.InputBox("Enter Username", "Username")
'P = Application.InputBox("Enter Password", "pwd")
U = "sebastin.fernando@cross-tab.com"
P = "sebi123"
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
apiShowWindow ie.hwnd, SW_MAXIMIZE
ie.Navigate "http://promise.cross-tab.com/"
Application.StatusBar = "Submitting"
' Wait while IE loading...
While ie.READYSTATE <> 4 Or ie.busy: DoEvents: Wend
' **********************************************************************
ie.document.getelementbyID("Username").Value = U
ie.document.getelementbyID("Password").Value = P
ie.document.getelementbyID("btnSignIn").Click
'**********************************************************************
' While ie.READYSTATE <> 4 Or ie.busy: DoEvents: Wend
delay 2
ie.Navigate "http://promise.cross-tab.com/schedule.html"
While ie.busy: DoEvents: Wend
For Z = 2 To Application.WorksheetFunction.CountA(Range("A:A"))
If Cells(Z, 7) <> "Done" Then
'delay 2
ie.Navigate "http://promise.cross-tab.com/scheduler/index.html"
' Wait while IE loading...
While ie.READYSTATE <> 4: DoEvents: Wend
delay 2
If Cells(Z, 9) = "Yes" Then
ie.document.getelementbyID("dhx_minical_icon").Click
ie.document.getelementsbyclassname("dhx_month_head")(Val(Format(Date, "dd"))).fireevent "*******", 1, 2
End If
ie.document.getelementsbyclassname("dhx_matrix_cell ")(0).fireevent "ondblclick", 1, 2
If InStr(Trim(LCase(ie.document.getelementsbyclassname("dhx_cal_ltext")(0).innertext)), Trim(LCase(Cells(Z, 1)))) = 0 Then
Cells(Z, 7) = "Programmer Not Available"
GoTo nextz
End If
Set Elements = ie.document.getelementsbytagname("Select")(0)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If Trim(LCase(txt)) = Trim(LCase(Cells(Z, 1))) Then
ie.document.getelementsbytagname("select")(0).Value = Va
ie.document.getelementsbytagname("select")(0).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
If InStr(Trim(LCase(ie.document.getelementsbyclassname("dhx_cal_ltext")(1).innertext)), Trim(LCase(Cells(Z, 2)))) = 0 Then
Cells(Z, 7) = "Project Not Available"
GoTo nextz
End If
Set Elements = ie.document.getelementsbytagname("Select")(1)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If Trim(LCase(txt)) = Trim(LCase(Cells(Z, 2))) Then
ie.document.getelementsbytagname("select")(1).Value = Va
ie.document.getelementsbytagname("select")(1).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
If InStr(Trim(LCase(ie.document.getelementsbyclassname("dhx_cal_ltext")(2).innertext)), Trim(LCase(Cells(Z, 3)))) = 0 Then
Cells(Z, 7) = "Add Programmer in the Project"
GoTo nextz
End If
Set Elements = ie.document.getelementsbytagname("Select")(2)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If InStr(Trim(LCase(txt)), Trim(LCase(Cells(Z, 3)))) > 0 Then
ie.document.getelementsbytagname("select")(2).Value = Va
ie.document.getelementsbytagname("select")(2).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
Set Elements = ie.document.getelementsbytagname("Select")(3)
'Show the element's properties
For Each Element In Elements
txt = Element.innertext
Va = Element.Value
If Trim(LCase(txt)) = Trim(LCase(Cells(Z, 4))) Then
ie.document.getelementsbytagname("select")(3).Value = Va
ie.document.getelementsbytagname("select")(3).fireevent ("onchange")
Exit For
Else
End If
Next
delay 0
ie.document.getelementsbytagname("input")(0).innertext = Cells(Z, 5).Value
ie.document.getelementsbytagname("textarea")(0).innertext = Cells(Z, 6).Value
ie.document.getelementsbyclassname("dhx_save_btn")(0).Click
Cells(Z, 7) = "Done"
Cells(Z, 8) = Date
'**********************************************************************
nextz:
Else
End If
Next Z
ie.Quit
Set ie = Nothing
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Allocation code ran successfully in " & MinutesElapsed & " HMS", vbInformation
Application.ScreenUpdating = True
End Sub
Private Sub delay(seconds As Long)
Dim endTime As Date
endTime = DateAdd("s", seconds, Now())
Do While Now() < endTime
DoEvents
Loop
End Sub