File works in Windows XP not in Vista
funtastick
Excel-VBA macro and Excel keeps crashing. I'm guessing that I haven't
mapped correctly to VB types. The code I use is below. Any pointers
would be appreciated.
This file works in Windows XP but not in Windows Vista
Thanks,
Option Explicit
Public Sub DoPerformanceTest()
Dim Brwsr As WebBrowser
Dim TestLinkCells As Range, n As Integer, TestURL As String, x As Integer
Dim TimeToReady As Double, TimeToComplete As Double
Dim rc As VbMsgBoxResult
rc = MsgBox("This will browse from your machine to the links listed in the
spreadsheet and time the responses." & vbCr & vbCr & _
"During the tests, please do not use your machine as this may affect
the results." & vbCr & vbCr & _
"Note that the statistics will not be accurate until the test is
complete.", vbOKCancel + vbInformation, "ITS Global")
If rc = vbCancel Then End
ClearBrowserCache False
GetUserDetails
Set TestLinkCells = ActiveWorkbook.Sheets("TestingSheet").Range("TestLinks")
For x = 1 To ActiveWorkbook.Sheets("TestingSheet").Range("TestResults").
Columns.Count
For n = 1 To TestLinkCells.Rows.Count
ActiveWorkbook.Sheets("TestingSheet").Range("TestResults").Cells(n, x)
Value = ""
Next n
Next x
Application.StatusBar = "Test running"
Set Brwsr = CreateObject("InternetExplorer.Application")
Brwsr.Visible = True
Brwsr.Navigate "about:home"
Do While Brwsr.Busy = True
Loop
Do While Brwsr.ReadyState = READYSTATE_LOADING
Loop
Do While Brwsr.Busy = True
Loop
Do Until Brwsr.ReadyState = READYSTATE_COMPLETE
Loop
For x = 1 To ActiveWorkbook.Sheets("TestingSheet").Range("TestResults").
Columns.Count
ClearBrowserCache True
For n = 1 To TestLinkCells.Rows.Count
TestURL = TestLinkCells.Cells(n, 1).Value
If LCase$(Left$(TestURL, 4)) = "http" Then
TimedBrowse Brwsr, TestURL, TimeToReady, TimeToComplete
'ActiveWorkbook.Sheets("TestingSheet").Range("TestResults").Cells
(n, 2 * (x - 1) + 1).Value = TimeToReady
ActiveWorkbook.Sheets("TestingSheet").Range("TestResults").Cells
(n, x).Value = TimeToComplete
ActiveWorkbook.Sheets("TestingSheet").Range("TestResults").Cells
(n, x).Activate
If (Application.Wait(Now + TimeValue("0:00:2")) = False) Then
MsgBox "Error with Wait"
End If
End If
Next n
Next x
Application.StatusBar = "Test complete"
End Sub
Sub ClearFolder(objFolder As Folder, objFSO As FileSystemObject)
Dim colSubfolders As Folders, objSubfolder As Folder
On Error Resume Next
'can't delete index.dat in Content.IE5 subfolder
objFSO.DeleteFile objFolder.Path & "\*.*", True
On Error GoTo 0
Set colSubfolders = objFolder.SubFolders
For Each objSubfolder In colSubfolders
ClearFolder objSubfolder, objFSO
On Error Resume Next
objSubfolder.Delete
On Error GoTo 0
Next objSubfolder
End Sub
Function ClearBrowserCache(NoWarn As Boolean) As Integer
Dim strComputer As String, objWMIService, colIESettings, strIESetting
Dim TempInternetFilesFolder As String, Confirm As VbMsgBoxResult
Dim objFS As FileSystemObject
Dim colSubfolders As Folders, objFolder As Folder, objSubfolder As Folder
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & _
"\root\cimv2\Applications\MicrosoftIE")
Set colIESettings = objWMIService.ExecQuery _
("Select * from MicrosoftIE_Cache")
For Each strIESetting In colIESettings
'MsgBox "Page refresh type: " & strIESetting.PageRefreshType
'MsgBox "Temporary Internet files folder: " & _
strIESetting.TempInternetFilesFolder
TempInternetFilesFolder = strIESetting.TempInternetFilesFolder
Next
If Not NoWarn Then
Confirm = MsgBox("This will delete the files in your Internet Explorer
cache folder (" & TempInternetFilesFolder & ")", vbExclamation + vbOKCancel)
If Confirm <> vbOK Then End
End If
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(TempInternetFilesFolder)
ClearFolder objFolder, objFS
End Function
Sub TimedBrowse(objBrowser As InternetExplorer, strURL As String, SecsToLoad
As Double, SecsToComplete As Double)
Dim StartTime As Double
Dim ReadyTime As Double
Dim CompleteTime As Double
StartTime = Timer
'Brwsr.GoHome
'MsgBox Brwsr.ReadyState & Brwsr.LocationURL
objBrowser.Navigate strURL, , "_self"
Application.StatusBar = "Browsing to " & strURL
Do While objBrowser.Busy = True
Loop
Do While objBrowser.ReadyState = READYSTATE_LOADING
Loop
ReadyTime = Timer
Application.StatusBar = "Completing download for " & strURL
Do While objBrowser.Busy = True
Loop
Do Until objBrowser.ReadyState = READYSTATE_COMPLETE
Loop
CompleteTime = Timer
SecsToLoad = (ReadyTime - StartTime)
SecsToComplete = (CompleteTime - StartTime)
End Sub
Sub GetUserDetails()
Dim WshNetworkObj As WshNetwork, strComputer As String, objWMIService,
colItems, objItem, strTime
Set WshNetworkObj = New WshNetwork
ActiveWorkbook.Sheets("TestingSheet").Range("TestUserName").Cells(1, 1).
Value = WshNetworkObj.UserDomain & "\" & WshNetworkObj.UserName
ActiveWorkbook.Sheets("TestingSheet").Range("TestComputer").Cells(1, 1).
Value = WshNetworkObj.ComputerName
Set WshNetworkObj = Nothing
ActiveWorkbook.Sheets("TestingSheet").Range("TestDate").Cells(1, 1).Value
= Now
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM
Win32_ComputerSystem")
For Each objItem In colItems
strTime = "GMT " & Format(objItem.CurrentTimeZone / 60, "+##")
If objItem.DaylightInEffect <> "" Then strTime = strTime & "
(Daylight Saving: " & objItem.DaylightInEffect & ")"
Next
ActiveWorkbook.Sheets("TestingSheet").Range("TestTimeZone").Cells(1, 1).
Value = strTime
Set colItems = Nothing
Set objWMIService = Nothing
End Sub
funtastick
>.Value = ""