excel vba xmlhttp with cookies, asynchronous, and with proxy support

http.vbs

' asynchronious http and synchronius http
' depends on Timer module

' ADD a referece to "Microsoft WinHTTP Services, version 5.1" (in Tools-> References)

Private Const CP_UTF8 = 65001
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

' http jobs example - async http
'Public Sub testasync_steps(Optional userarg As Variant = "", Optional step As Variant = 0, Optional data As String = "", Optional cookie As String = "", Optional haderror As Boolean = False)
'   If haderror Then
'    Exit Sub ' exit sub on errors, don't continue
'   End If
'   Select Case step
'   Case 0:
'    http_addjob "testasync_steps", 1, cookie, userarg, "http://www.exmaple.com/"
'   Case 1:
'    http_addjob "testasync_steps", 2, cookie, userarg, "http://www.example.com/list"
'   Case 2:
'    http_addjob "testasync_steps", 3, cookie, userarg, "http://www.example.com/item"
'   Case 3:
'    MsgBox data
'   End Select
'End Sub
'
'Public Sub testasync()
'
'  testasync_steps
'
'End Sub


Private http_jobs() As http_job, http_jobs_timer, http_jobs_active, http_jobs_size


Private Type http_job
 Cookie As String
 stepsfunction As String
 step As Variant
 http As MSXML2.ServerXMLHTTP
 inuse As Boolean
 userarg As Variant
 timeout As Date
 url As String
 post As String
End Type

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub onhttptimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
On Error GoTo exithttptimer
If ExcelIsBusy() Then Exit Sub
''    With Application
''        .ScreenUpdating = False
''        .EnableEvents = False
''    End With
stophttptimerid (idEvent)
If http_jobs_active Then Exit Sub
 If http_jobs_count() = 0 Then
  'stophttptimer
  'stophttptimerid (idEvent)
  http_jobs_free
  DoEvents
 Else
  http_process_jobs
  DoEvents
  starthttptimer
 End If

''    With Application
''        .ScreenUpdating = True
''        .EnableEvents = True
''    End With
GoTo exithttptimer_noerror
exithttptimer:

 If Err.Number <> 0 Then
  Msg = "Error # " & str(Err.Number) & " was generated by " & Err.source & vbCrLf & "Error Line: " & Erl & vbCrLf & Err.Description
  MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
 End If
 Resume Next
exithttptimer_noerror:
End Sub
'
Private Sub starthttptimer()
 If http_jobs_active = True Then Exit Sub
 If IsEmpty(http_jobs_timer) Then
  'MsgBox "starting timer"
  http_jobs_timer = SetTimeout(200, AddressOf onhttptimer)
'Else
  ' MsgBox "timer already running"
 End If
End Sub

Private Sub stophttptimer()
 If http_jobs_timer > 0 Then
  KillTimer 0, http_jobs_timer
  http_jobs_timer = Empty
 End If
End Sub

Private Sub stophttptimerid(id As Long)
 If id > 0 Then
  KillTimer 0, id
  http_jobs_timer = Empty
 End If
End Sub

Private Function http_jobs_next_free()
 If IsEmpty(http_jobs_size) Then http_jobs_size = 0
 Dim i
 For i = 0 To http_jobs_size - 1
  With http_jobs(i)
   If .inuse <> True Then
    http_jobs_next_free = i
   Exit Function
  End If
 End With
 Next
 
 ReDim Preserve http_jobs(http_jobs_size + 100)
 http_jobs_size = http_jobs_size + 100
 http_jobs_next_free = i + 1
End Function

Sub http_process_jobs()
 http_jobs_active = True
 If IsEmpty(http_jobs_size) Then http_jobs_size = 0
 Dim i
 For i = 0 To http_jobs_size - 1
  With http_jobs(i)
    If .inuse = True Then
    If .http.readyState = 4 Then
    
    Dim data, stepsfuncton, step, Cookie, haderror, userarg
    Set userarg = .userarg
    Cookie = .Cookie
    If .http.Status = 200 Then
     
     'Parse response cookie headers & can be used for session state persistence
     
     Dim strHeaders, hArr, kk, theCookie
     strHeaders = .http.getAllResponseHeaders()
     'MsgBox strHeaders
     'Exit Function
     hArr = Split(strHeaders, vbCrLf)
     Dim t, p, firstpos
     For kk = 0 To UBound(hArr) - 1
      t = hArr(kk)
      If Mid(t, 1, Len("Set-Cookie: ")) = "Set-Cookie: " Then
         firstpos = Len(t)
         p = InStr(1, t, "; Path=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
         p = InStr(1, t, "; Domain=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
         p = InStr(1, t, "; Max-Age=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
         p = InStr(1, t, "; Secure=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
         p = InStr(1, t, "; Version=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
         p = InStr(1, t, "; HTTPOnly", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
         theCookie = Mid(t, Len("Set-Cookie: ") + 1, firstpos - 1 - Len("Set-Cookie: "))
         If Cookie = "" Then
          Cookie = theCookie
         Else
          Cookie = Cookie & "; " & theCookie
         End If
       End If
      Next
      Cookie = Trim(Cookie)
      'Return response content
      'If debug = False Then
      
      data = .http.responseText
      haderror = False
    Else
     data = ""
     haderror = True
     End If
    'Else
    '    'return response headers + content for debugging
    '    httpGet = strHeaders & XMLHTTP.responseText
    'End If
     Set .http = Nothing
     stepsfuncton = .stepsfunction
     step = .step
     .inuse = False
     Application.Run stepsfuncton, userarg, step, data, Cookie, haderror
    ElseIf .http.readyState < 4 Then
     If .timeout < Now() Then
      .http.abort
      .inuse = False
      http_addjob_add .stepsfunction, .step, .Cookie, .userarg, .url, .post
     End If
    End If ' ready=4
   End If ' in use
  End With
  DoEvents
 Next
 http_jobs_active = False
End Sub

Sub http_jobs_free()
 If IsEmpty(http_jobs_size) Then http_jobs_size = 0
 Dim i
 For i = 0 To http_jobs_size - 1
  With http_jobs(i)
   If TypeName(.http) <> "Nothing" Then Set .http = Nothing
  End With
 Next
End Sub

Function http_jobs_count()
 If IsEmpty(http_jobs_size) Then http_jobs_size = 0
 Dim i, c
 c = 0
 For i = 0 To http_jobs_size - 1
  With http_jobs(i)
   If .inuse Then c = c + 1
  End With
 Next
 http_jobs_count = c
End Function

Sub http_addjob_add(stepsfunction As String, nextstep As Variant, Optional Cookie As String = "", Optional userarg As Variant = "", Optional url As String, Optional post As String = "")
If url = "" Then
 Err.Raise 1000001, "http_addjob, http get module", "url is not optional must be not empty"
 Exit Sub
End If
Dim nextfree
nextfree = http_jobs_next_free()
With http_jobs(nextfree)
    If TypeName(.http) = "Nothing" Then
     Set .http = New MSXML2.ServerXMLHTTP
     Dim lResolve As Long, lConnect As Long, lSend As Long, lReceive As Long
      lResolve = 50000
      lConnect = 120000
      lSend = 240000
      lReceive = 350000
      .http.setTimeouts lResolve, lConnect, lSend, lReceive
     End If
    
    .inuse = True
    .stepsfunction = stepsfunction
    .step = nextstep
    Set .userarg = userarg
    
     'Set dummy cookie, if none (or "") provided
    
    Cookie = Trim(Cookie)
    If Len(Cookie) = 0 Then
        Cookie = ""
    End If
    
    'Set up GET request (synchronous)
    If post = "" Then
     .http.Open "GET", Trim(url), True
    Else
     .http.Open "POST", Trim(url), True
     .http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    End If
    .http.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    If Len(Cookie) > 0 Then
     .http.setRequestHeader "Cookie", Cookie
    End If
    .timeout = Now() + TimeSerial(0, 0, 40)
    .Cookie = Cookie
    .post = post
    .url = url
    'Make request:
    .http.send post 'send no data/blank data since is GET request
End With
End Sub

Sub http_addjob(stepsfunction As String, nextstep As Variant, Optional Cookie As String = "", Optional userarg As Variant = "", Optional url As String, Optional post As String = "")
 http_addjob_add stepsfunction, nextstep, Cookie, userarg, url, post
 starthttptimer
End Sub


Public Function findkey(dict, key) As Integer
   Dim a, d, i   ' Create some variables.
   'Set dict = CreateObject("Scripting.Dictionary")
   findkey = -1
   a = dict.keys   ' Get the keys.
   For i = 0 To dict.Count - 1 ' Iterate the array.
      If a(i) = key Then
       findkey = i
       Exit Function
      End If
   Next
End Function

Public Function HttpGet(url, ByRef Cookie, Optional post = "", Optional areferer = "") As String
    Dim redirect

    'Set dummy cookie, if none (or "") provided
    Trim (Cookie)
    If Len(Cookie) = 0 Then
        Cookie = ""
    End If
 
    'Initialize XMLHttp Object
    'Use the best/proper XMLHttp object available on your system
    
    'Dim XMLHTTP  As MSXML2.ServerXMLHTTP60
    'Set XMLHTTP = New MSXML2.ServerXMLHTTP60 'Set XMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    ' with ServerXMLHTTP had a problem when cookies sent on redirect i could not get them. only got cookies from second request and they ware empty. then ServerXMLHTTP does not enables to not handle redirects so i switched to WinHttpRequest which does
    ' WinHttpRequest for windows XP
    '
    Dim XMLHTTP  As WinHttp.WinHttpRequest 'http://stackoverflow.com/questions/1639658/do-i-really-need-to-register-winhttp-on-windows-server-2008-before-using-winhttp
    Set XMLHTTP = New WinHttp.WinHttpRequest 'Set webClient = CreateObject("WinHttp.WinHttpRequest.5.1") ' needs Microsoft WinHTTP Services 5.1 reference
    
    
    'Set XMLHTTP = CreateObject("Msxml2.XMLHTTP")
    'Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")

    'XMLHTTP.setProxy 2, "http://127.0.0.1:8888", ""  ' unomment this to set proxy, you can download fiddler proxy

    XMLHTTP.Option(WinHttpRequestOption_EnableRedirects) = False ' WinHttpRequestOption_EnableRedirects=6
    
    
    Do
     redirect = False
    'Set up GET request (synchronous)
    If post = "" Then
     XMLHTTP.Open "GET", Trim(url), False
    Else
     XMLHTTP.Open "POST", Trim(url), False
     XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    End If
    'XMLHTTP.setRequestHeader "Connection", "close"
    'objHTTP.SetOption(2, objHTTP.GetOption(2) - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS)

    XMLHTTP.setRequestHeader "Cache-Control", "Max-age=0"
    XMLHTTP.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
    XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 5.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/29.0.1547.62 Safari/537.36"
    'XMLHTTP.setRequestHeader "Accept-Encoding", "gzip , deflate, sdch"
    XMLHTTP.setRequestHeader "Accept-Language", "he-IL,he;q=0.8,en-US;q=0.6,en;q=0.4"
    
    'XMLHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    
    If areferer <> "" Then XMLHTTP.setRequestHeader "Referer", areferer
    
    If Len(Cookie) > 0 Then
     'XMLHTTP.setRequestHeader "Cookie", "excuse the Microsoft bug"
     XMLHTTP.setRequestHeader "Cookie", Cookie
    End If
    'Make request
    XMLHTTP.send post 'send no data/blank data since is GET request
    
    'wait for response
    Dim succesded
    succesded = False
    While Not succesded
            succesded = XMLHTTP.waitForResponse(200)
            DoEvents
    Wend
    
    'Parse response cookie headers & can be used for session state persistence
    Dim strHeaders, hArr, kk, theCookie
    strHeaders = XMLHTTP.getAllResponseHeaders()
    consolelog ("Headers:" + vbCrLf + post)
    'MsgBox strHeaders
    'Exit Function
    hArr = Split(strHeaders, vbCrLf)
    Dim t, p, firstpos
    For kk = 0 To UBound(hArr) - 1
     t = hArr(kk)
     If Mid(t, 1, Len("Set-Cookie: ")) = "Set-Cookie: " Then
        firstpos = Len(t)
        p = InStr(1, t, "; Path=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
        p = InStr(1, t, "; Domain=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
        p = InStr(1, t, "; Max-Age=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
        p = InStr(1, t, "; Secure=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
        p = InStr(1, t, "; Version=", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
        p = InStr(1, t, "; HTTPOnly", vbTextCompare): If p > 0 And p < firstpos Then firstpos = p
        theCookie = Mid(t, Len("Set-Cookie: ") + 1, firstpos - 1 - Len("Set-Cookie: "))
        If Cookie = "" Then
         Cookie = theCookie
        Else
         Cookie = Cookie & "; " & theCookie
        End If
     End If
     If Mid(t, 1, Len("Location: ")) = "Location: " Then
       theCookie = Mid(t, Len("Location: ") + 1)
       url = extend_url(url, theCookie)
       post = ""
       redirect = True
     End If
    Next
    Cookie = Trim(Cookie)
    
    'DROP REPEATED COOKIES
    Dim cookie2

    Dim dict As New Scripting.Dictionary
    dict.RemoveAll
    Dim regEx As New VBScript_RegExp_55.RegExp
    Dim matches, s
    regEx.Pattern = "([^=]+)=([^;]+);"
    regEx.IgnoreCase = True 'True to ignore case
    regEx.Global = True 'True matches all occurances, False matches the first occurance
    If regEx.Test(Cookie) Then
        Set matches = regEx.Execute(Cookie)
        For Each Match In matches
            If dict.Exists("" & Match.SubMatches(0)) Then
             dict.Items(findkey(dict, Match.SubMatches(0))) = Match.SubMatches(1)
            Else
             dict.Add Match.SubMatches(0), Match.SubMatches(1)
            End If
        Next
    End If

    cookie2 = ""
    Dim i As Integer
    For i = 0 To dict.Count - 1 ' lower index 0 (instead of 1)
      cookie2 = cookie2 & dict.keys(i) & "=" & dict.Items(i) & "; "
    Next i
    Cookie = Trim(cookie2)
    
    Loop While redirect
    
       ' consolelog ("cookie: " + cookie)
       ' consolelog (XMLHTTP.responseText)
        
    'Return response content
    'If debug = False Then
        HttpGet = XMLHTTP.responseText

    'Else
    '    'return response headers + content for debugging
    '    httpGet = strHeaders & XMLHTTP.responseText
    'End If
    Set XMLHTTP = Nothing
End Function


'Sub update_options_list()
'   Dim url1, url2, url3, cookie, data
'   url1 = "http://www.example.com/"
'   url2 = "http://www.example.com/list"
'   url3 = "http://www.example.com/item"
'
'   data = HttpGet(url1, cookie)
'   data = HttpGet(url2, cookie)
'   data = HttpGet(url3, cookie)
'   Dim trows, tcols, row, col
'   trows = Split(data, vbCrLf)
'   Sheet15.Cells.Clear
'   For row = 0 To UBound(trows) - 1
'    tcols = Split(trows(row), vbTab)
'    For col = 0 To UBound(tcols) - 1
'     Sheet15.Cells(row + 1, col + 1).Value = tcols(col)
'    Next
'   Next
'End Sub


Public Function UTF16To8(ByVal UTF16 As String) As String
Dim sBuffer As String
Dim lLength As Long
If UTF16 <> "" Then
    lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
    sBuffer = Space$(lLength)
    lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
    sBuffer = StrConv(sBuffer, vbUnicode)
    UTF16To8 = Left$(sBuffer, lLength - 1)
Else
    UTF16To8 = ""
End If
End Function

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False, _
   Optional UTF8Encode As Boolean = True _
) As String

Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
Dim StringLen As Long: StringLen = Len(StringValCopy)

If StringLen > 0 Then
    ReDim Result(StringLen) As String
    Dim i As Long, CharCode As Integer
    Dim Char As String, Space As String

  If SpaceAsPlus Then Space = "+" Else Space = "%20"

  For i = 1 To StringLen
    Char = Mid$(StringValCopy, i, 1)
    CharCode = Asc(Char)
    Select Case CharCode
      Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
        Result(i) = Char
      Case 32
        Result(i) = Space
      Case 0 To 15
        Result(i) = "%0" & Hex(CharCode)
      Case Else
        Result(i) = "%" & Hex(CharCode)
    End Select
  Next i
  URLEncode = Join(Result, "")

End If
End Function


Public Function comment_out_script(html)
 html = Replace(html, "<script", "<!--script", 1, -1, vbTextCompare)
 html = Replace(html, "</script>", "</script-->", 1, -1, vbTextCompare)
 html = Replace(html, " onload=", " 0onload=", 1, -1, vbTextCompare)
 html = Replace(html, " onunload=", " 0onunload=", 1, -1, vbTextCompare)
 html = Replace(html, " onreadystatechange=", " 0onreadystatechange=", 1, -1, vbTextCompare)
 html = Replace(html, " src=", " 0src=", 1, -1, vbTextCompare)
 comment_out_script = html
End Function


'Sub test_extend_url()
'Dim x
'x = extend_url("http://www.google.com/asdfasdf/?24234=/", "346")
'End Sub

Public Function extend_url(baseurl, relativeurl)
    If InStr(baseurl, "?") <> 0 Then
     baseurl = Mid(baseurl, 1, InStr(baseurl, "?") - 1)
    End If
    If InStr(8, baseurl, "/") = 0 Then
        baseurl = baseurl & "/"
    ElseIf Mid(baseurl, Len(baseurl), 1) <> "/" Then
        baseurl = Mid(baseurl, 1, InStrRev(baseurl, "/"))
    End If
    If Mid(relativeurl, 1, 7) = "http://" Or Mid(relativeurl, 1, 8) = "https://" Then
        extend_url = relativeurl
    'ElseIf Mid(relativeurl, 1, 2) = "//" Then ' rare case of html5
    '   extend_url = "http:" & relativeurl
    ElseIf Mid(relativeurl, 1, 1) = "/" Then
        extend_url = baseurl & Mid(relativeurl, 2, Len(relativeurl) - 1)
    Else
        extend_url = baseurl & relativeurl
    End If
End Function


Public Function StringStartsWith(ByVal strValue As String, _
  CheckFor As String, Optional CompareType As VbCompareMethod _
   = vbBinaryCompare) As Boolean
   
'Determines if a string starts with the same characters as
'CheckFor string

'True if starts with CheckFor, false otherwise
'Case sensitive by default.  If you want non-case sensitive, set
'last parameter to vbTextCompare
    
    'Examples:
    'MsgBox StringStartsWith("Test", "TE") 'false
    'MsgBox StringStartsWith("Test", "TE", vbTextCompare) 'True
    
  Dim sCompare As String
  Dim lLen As Long
   
  lLen = Len(CheckFor)
  If lLen > Len(strValue) Then Exit Function
  sCompare = Left(strValue, lLen)
  StringStartsWith = StrComp(sCompare, CheckFor, CompareType) = 0

End Function

Public Function StringEndsWith(ByVal strValue As String, CheckFor As String, Optional CompareType As VbCompareMethod = vbBinaryCompare) As Boolean
 'Determines if a string ends with the same characters as
 'CheckFor string
 
 'True if end with CheckFor, false otherwise

 'Case sensitive by default.  If you want non-case sensitive, set
 'last parameter to vbTextCompare
 
  'Examples
  'MsgBox StringEndsWith("Test", "ST") 'False
  'MsgBox StringEndsWith("Test", "ST", vbTextCompare) 'True

  Dim sCompare As String
  Dim lLen As Long
   
  lLen = Len(CheckFor)
  If lLen > Len(strValue) Then Exit Function
  sCompare = Right(strValue, lLen)
  StringEndsWith = StrComp(sCompare, CheckFor, CompareType) = 0

End Function

    ' needs "Microsoft VBScript Regular Expressions 5.5" reference http://lispy.wordpress.com/2008/10/17/using-regex-functions-in-excel/
    
    ' List of characters handled:
    ' \000 null
    ' \010 backspace
    ' \011 horizontal tab
    ' \012 new line
    ' \015 carriage return
    ' \032 substitute
    ' \042 double quote
    ' \047 single quote
    ' \134 backslash
    ' \140 grave accent
    
    ' Returns a string with backslashes before characters that need to be quoted in database queries
    Function addslashes(unsafeString) ' by reusablecode.blogspot.com
        Dim regEx

        Set regEx = New RegExp
        
        With regEx
            .Global = True
            .IgnoreCase = True
            .Pattern = "([\000\010\011\012\015\032\042\047\134\140])"
        End With
        
        addslashes = regEx.Replace(unsafeString, "\$1")
    
        Set regEx = Nothing
    End Function

    ' Un-quote string quoted with addslashes()
    Function stripslashes(safeString) ' by reusablecode.blogspot.com
        Dim regEx

        Set regEx = New RegExp
        
        With regEx
            .Global = True
            .IgnoreCase = True
            .Pattern = "\\([\000\010\011\012\015\032\042\047\134\140])"
        End With
        
        stripslashes = regEx.Replace(safeString, "$1")
    
        Set regEx = Nothing
    End Function

timer.vbs

' timer module for excel,

' for 32bit excel, a 64 bit excel needs different declarations

Option Explicit

Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Dim timererroronce

'Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
 'iCounter = iCounter + 1
 'Form1.Text1.Text = CStr(iCounter)
'End Sub
'Dim timer1
'timer1=SetTimeout(timer As Long, AddressOf TimerProc)
'KillTimer 0, timer1

Function SetTimeout(NumberOfSeconds As Long, AddressOffunction As Long)
   SetTimeout = SetTimer(0&, 0&, NumberOfSeconds, AddressOffunction)
   If SetTimeout = 0 Then
    If timererroronce <> True Then
     MsgBox "Timer not created. Ending Program"
     timererroronce = True
    End If
    Exit Function
   End If
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Sub savedata(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
'If ExcelIsBusy() Then Exit Sub
'
''    With Application
''        .ScreenUpdating = False
''        .EnableEvents = False
''    End With
'
'Sheet2.Range("B1").Value = Now()
'
''    With Application
''        .ScreenUpdating = True
''        .EnableEvents = True
''    End With
'
'End Sub


Function ExcelIsBusy()
ExcelIsBusy = Not Application.Ready
Dim m
m = Empty
Const MENU_ITEM_TYPE = 1
Const NEW_MENU = 18

Dim oNewMenu
Set oNewMenu = Application.CommandBars("Worksheet Menu Bar").FindControl(MENU_ITEM_TYPE, NEW_MENU, m, m, True)
If Not (oNewMenu Is Nothing) Then
    If Not oNewMenu.Enabled Then
        ExcelIsBusy = True
        'throw new Exception("Excel is in Edit Mode")
    End If
End If

End Function

'example usage

'Dim timersavedata ''''''''' notice this external variable
'
'Sub saveonce()
'savedata 0, 0, 0, 0
'End Sub
'
'Sub clearsaved()
'Dim n As Integer
'n = Sheet2.Range("B1").Value
'Sheet2.Range("A" & 8 & ":EN" & n).Clear
'End Sub
'
'
'
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Sub savedata(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
'If ExcelIsBusy() Then Exit Sub
''    With Application
''        .ScreenUpdating = False
''        .EnableEvents = False
''    End With
'
'
''Range("A3").Calculate
'Dim x, l, r As Range, n As Integer
'n = Sheet2.Range("B1").Value + 1
'Set r = Sheet2.Range("A3:EN3")
'l = r.Count
'ReDim ar(l)
'For x = 0 To l
' ar(x) = r(1, x + 1)
'Next
'Sheet2.Range("A" & n & ":EN" & n).Value = ar
'
''    With Application
''        .ScreenUpdating = True
''        .EnableEvents = True
''    End With
'End Sub
'
'Sub startsavetimer()
' If IsEmpty(timersavedata) Then
'  MsgBox "starting timer"
'  timersavedata = SetTimeout(1000, AddressOf savedata)
'  Else
'   MsgBox "timer already running"
' End If
'End Sub
'
'Sub stopsavetimerid(id as Long)
' If timersavedata > 0 Then
'  KillTimer 0, id
'  timersavedata = Empty
' End If
'End Sub
'
'Sub stopsavetimer()
' If timersavedata > 0 Then
'  MsgBox "stopping timer"
'  KillTimer 0, timersavedata
'  timersavedata = Empty
'  Else
'   MsgBox "timer already stopped"
' End If
'End Sub
'
'
'Sub stopsavetimersilent()
' If timersavedata > 0 Then
'  KillTimer 0, timersavedata
'  timersavedata = Empty
' End If
'End Sub