I had a file (Theme file) that is stored on Sharepoint and first needed to be downloaded into the temp directory before being loaded applied to word. This worked for a while, but recently I am getting an "access denied error".
I looked around and tested other libraries CreateObject("MSXML2.ServerXMLHTTP.6.0") instead of CreateObject("Microsoft.XMLHTTP").
Interestingly, I don't get the access error message with CreateObject("MSXML2.ServerXMLHTTP.6.0"), but instead it dowloads a page with this error:
[![Screenshot of error message][1]][1]
We can't sign you in
Your browser is currently set to block cookies. You need to allow cookies to use this service.
Cookies are small text files stored on your computer that tell us when you're signed in. To learn how to allow cookies, check the online help in your web browser.
I hope someone has an idea about why this error occurs and how to solve it
Here is the code I use.
Public Sub Download(ByVal URL As String, ByVal FilePath As String, Optional ByVal Overwrite As Boolean = True)
Dim iOverwrite, oStrm
If (IsNull(Overwrite) Or Overwrite) Then
iOverwrite = 2
Else
iOverwrite = 1
End If
Dim HttpReq As Object
'NOTE: There are some issues downloading if not properly logged in! May need to loggin sharepoint again
' https://www.codeproject.com/Questions/1101499/Download-files-from-API-using-vbscript-cmd-prompt
' Based on https://stackoverflow.com/questions/22938194/xmlhttp-request-is-raising-an-access-denied-error
'Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Set HttpReq = CreateObject("Microsoft.XMLHTTP")
'Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP.3.0")
HttpReq.Open "GET", URL, False, "username", "password"
On Error GoTo ErrorHandler
HttpReq.send
On Error GoTo 0
If HttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
oStrm.Open
oStrm.Type = 1
oStrm.Write HttpReq.responseBody
oStrm.SaveToFile FilePath, iOverwrite ' 1 = no overwrite, 2 = overwrite
oStrm.Close
End If
Exit Sub
ErrorHandler:
MsgBox "The file could not be downloaded. Verify that you are logged in SharePoint with word and browser.", vbCritical, "Download error"
Debug.Print "Download - Error Downloading file will not be downloaded - Error #: '" & Err.Number & "'. Error description: " & Err.description
End Sub```
[1]: https://i.stack.imgur.com/pdH6v.png
I use import function specifically designed for this. I use Sharepoint Teams site (no user/password can be sent for auth).
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Function downloadSP(ByVal url As String, ByVal nm As String) As Long
DownloadFileFromWeb = URLDownloadToFile(0, url, nm, 0, 0) ' nm includes filename
End Function
In addition. I have to first use an ADO query to the sharepoint library directly before. This ADO connection handles authentication and allows subsequent downloads to location. There probably is another method for sending Teams authentication, but this works just fine. (it's also a great way to get data from SP List/Libraries or even within Excel files)
If testConnected Then downloadSP url, nm
Function testConnected() As Boolean
Dim cn As Object
Dim rs As Object
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
listGUID = "B3657D15-5F5C-468E-B1C2-784B930FE2E6"
siteURL = "https://azuresite.sharepoint.com/sites/test/"
spSql = "Select * from ['https://azuresite.sharepoint.com/sites/test/SL%20Template/Forms/AllItems.aspx']"
cnStr = "Provider=Microsoft.ACE.OLEDB.16.0;WSS;IMEX=2;RetrieveIds=No;DATABASE=" & siteURL & "; LIST=" & listGUID & ";"
cn.ConnectionString = cnStr
On Error GoTo NotConnected
cn.Open
rs.Open spSql, cn, 1, 2
testConnected = True
cn.Close
Exit Function
NotConnected:
testConnected = False
Exit Function
End Function
So I managed to solve this issue after:
enabling accepting cookies from: https://login.microsoftonline.com/ and our SharePoint sites (also added them in trusted websites)
Clearing the cookies from the history
Use the "Microsoft.XMLHTTP" library which works (other libraries do not seem to work properly still)
Related
I'm working on adding a document upload function to an application I've written. I want the user to be able to upload, open, and delete a document on a network drive that they cannot access normally. With this in mind, I stumbled upon Impersonation, where the user can impersonate a user account that has full rights to the drive, then dispose of that after the code has been executed.
I've never used impersonation before, so during my research I found this thread:
Impersonate a Windows or Active Directory user from a different, untrusted domain
I created and copied the class that user Max Vernon had posted as follows:
Option Explicit On
Option Infer Off
Imports System
Imports System.Runtime.InteropServices ' DLL Import
Imports System.Security.Principal ' WindowsImpersonationContext
Imports System.ComponentModel
Public Class Impersonation
'Group Type Enum
Enum SECURITY_IMPERSONATION_LEVEL As Int32
SecurityAnonymous = 0
SecurityIdentification = 1
SecurityImpersonation = 2
SecurityDelegation = 3
End Enum
Public Enum LogonType As Integer
'This logon type is intended for users who will be interactively using the computer, such as a user being logged on
'by a terminal server, remote shell, or similar process.
'This logon type has the additional expense of caching logon information for disconnected operations,
'therefore, it is inappropriate for some client/server applications, such as a mail server.
LOGON32_LOGON_INTERACTIVE = 2
'This logon type is intended for high performance servers to authenticate plaintext passwords.
'The LogonUser function does not cache credentials for this logon type.
LOGON32_LOGON_NETWORK = 3
'This logon type is intended for batch servers, where processes may be executing on behalf of a user without
'their direct intervention. This type is also for higher performance servers that process many plaintext
'authentication attempts at a time, such as mail or Web servers.
'The LogonUser function does not cache credentials for this logon type.
LOGON32_LOGON_BATCH = 4
'Indicates a service-type logon. The account provided must have the service privilege enabled.
LOGON32_LOGON_SERVICE = 5
'This logon type is for GINA DLLs that log on users who will be interactively using the computer.
'This logon type can generate a unique audit record that shows when the workstation was unlocked.
LOGON32_LOGON_UNLOCK = 7
'This logon type preserves the name and password in the authentication package, which allows the server to make
'connections to other network servers while impersonating the client. A server can accept plaintext credentials
'from a client, call LogonUser, verify that the user can access the system across the network, and still
'communicate with other servers.
'NOTE: Windows NT: This value is not supported.
LOGON32_LOGON_NETWORK_CLEARTEXT = 8
'This logon type allows the caller to clone its current token and specify new credentials for outbound connections.
'The new logon session has the same local identifier but uses different credentials for other network connections.
'NOTE: This logon type is supported only by the LOGON32_PROVIDER_WINNT50 logon provider.
'NOTE: Windows NT: This value is not supported.
LOGON32_LOGON_NEW_CREDENTIALS = 9
End Enum
Public Enum LogonProvider As Integer
'Use the standard logon provider for the system.
'The default security provider is negotiate, unless you pass NULL for the domain name and the user name
'is not in UPN format. In this case, the default provider is NTLM.
'NOTE: Windows 2000/NT: The default security provider is NTLM.
LOGON32_PROVIDER_DEFAULT = 0
LOGON32_PROVIDER_WINNT35 = 1
LOGON32_PROVIDER_WINNT40 = 2
LOGON32_PROVIDER_WINNT50 = 3
End Enum
'Obtains user token.
Declare Auto Function LogonUser Lib "advapi32.dll" (ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, ByVal dwLogonType As LogonType, ByVal dwLogonProvider As LogonProvider, ByRef phToken As IntPtr) As Integer
'Closes open handles returned by LogonUser.
Declare Function CloseHandle Lib "kernel32.dll" (ByVal handle As IntPtr) As Boolean
'Creates duplicate token handle.
Declare Auto Function DuplicateToken Lib "advapi32.dll" (ExistingTokenHandle As IntPtr, SECURITY_IMPERSONATION_LEVEL As Int16, ByRef DuplicateTokenHandle As IntPtr) As Boolean
'WindowsImpersonationContext newUser.
Private newUser As WindowsImpersonationContext
'Attempts to impersonate a user. If successful, returns
'a WindowsImpersonationContext of the new user's identity.
'
'Username that you want to impersonate.
'Logon domain.
'User's password to logon with.
Public Sub Impersonator(ByVal sDomain As String, ByVal sUsername As String, ByVal sPassword As String)
'Initialize tokens
Dim pExistingTokenHandle As New IntPtr(0)
Dim pDuplicateTokenHandle As New IntPtr(0)
If sDomain = "" Then
sDomain = System.Environment.MachineName
End If
Try
Const LOGON32_PROVIDER_DEFAULT As Int32 = 0
Const LOGON32_LOGON_NEW_CREDENTIALS = 9
Dim bImpersonated As Boolean = LogonUser(sUsername, sDomain, sPassword, LOGON32_LOGON_NEW_CREDENTIALS, LOGON32_PROVIDER_DEFAULT, pExistingTokenHandle)
If bImpersonated = False Then
Dim nErrorCode As Int32 = Marshal.GetLastWin32Error()
Throw New ApplicationException("LogonUser() failed with error code: " & nErrorCode.ToString)
End If
Dim bRetVal As Boolean = DuplicateToken(pExistingTokenHandle, SECURITY_IMPERSONATION_LEVEL.SecurityImpersonation, pDuplicateTokenHandle)
If bRetVal = False Then
Dim nErrorCode As Int32 = Marshal.GetLastWin32Error
CloseHandle(pExistingTokenHandle)
Throw New ApplicationException("DuplicateToken() failed with error code: " & nErrorCode)
Else
Dim newId As New WindowsIdentity(pDuplicateTokenHandle)
Dim impersonatedUser As WindowsImpersonationContext = newId.Impersonate
newUser = impersonatedUser
End If
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
Finally
If pExistingTokenHandle <> IntPtr.Zero Then
CloseHandle(pExistingTokenHandle)
End If
If pDuplicateTokenHandle <> IntPtr.Zero Then
CloseHandle(pDuplicateTokenHandle)
End If
End Try
End Sub
Public Sub Undo()
newUser.Undo()
End Sub
End Class
The impersonation works great for "uploading" (actually just copying a file over from the users local files to the network drive, creating a specific file path if it doesn't exist) but doesn't seem to work when trying to open the file back up, or delete said file.
I get an access denied error like this:
Error Message When Trying to Open File
The Open File Click Event and Class Call Looks Like This:
Private Sub btnOpenDoc_Click(sender As Object, e As EventArgs) Handles btnOpenDoc.Click
Dim Impersonator As New Impersonation
Dim sUser As String = "UserNameGoesHere"
Dim sPass As String = "PasswordGoesHere"
Dim sDomain As String = "DomainGoesHere"
Try
If sActionID <> "" And iDocument = 1 Then
'Starts impersonation
Impersonator.Impersonator(sDomain, sUser, sPass)
Process.Start(RetrieveFilePath())
'Ends Impersonation
Impersonator.Undo()
End If
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
modGlobal.WriteToErrorLog(ex.Message, "frmActionEntry", modGlobal.GetExceptionInfo(ex), "frmActionEntry->btnOpenDoc_Click", currentUser.getEmployeeName())
End Try
End Sub
Here's Document Delete Function:
Private Function DeleteFile() As Boolean
Dim Impersonator As New Impersonation
Dim sUser As String = "UsernameGoesHere"
Dim sPass As String = "PasswordGoesHere"
Dim sDomain As String = "DomainGoesHere"
Try
'Starts impersonation
Impersonator.Impersonator(sDomain, sUser, sPass)
File.Delete(RetrieveFilePath())
Return True
'Ends Impersonation
Impersonator.Undo()
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
modGlobal.WriteToErrorLog(ex.Message, "frmActionEntry", modGlobal.GetExceptionInfo(ex), "frmActionEntry->DeleteFile", currentUser.getEmployeeName())
Return False
End Try
End Function
It's used in basically the same way in the FileSave function. Like I said I'm new to impersonation, and feel like I've hit a wall, having researched and tried various things all morning. Any advice is much appreciated!
-Levi
So after much research and trial and error I have an answer to this.
The short answer:
There is not a clean, elegant way to use impersonation to open a file on a network drive because you either butt heads with Windows Security or run into problems with Windows Shell. I decided to go another route.
The long answer:
I believe I was correct in that the Access was Denied error was due to trying to open a file as the impersonated user on the local user's computer. To get around this I decided to try and use ProcessStartInfo() to pass in the correct credentials (while also using impersonation to access the drive) like this:
'Opens the document associated with this action
Private Sub btnOpenDoc_Click(sender As Object, e As EventArgs) Handles btnOpenDoc.Click
'Initializes an impersonation object
Dim Impersonator As New Impersonation
'Strings with login credentials
Dim sUser As String = "UsernameGoesHere"
Dim sPass As String = "PasswordGoesHere"
Dim sDomain As String = "DomainGoesHere"
'Used to load file path in from RetrieveFilePath()
Dim sPath As String = ""
Try
If sActionID <> "" And iDocument = 1 Then
'Starts impersonation
Impersonator.Impersonator(sDomain, sUser, sPass)
'Initializes a ProcessStartInfo Object to use with impersonation
'as Process.Start class always inherits the security context of
'the parent process i.e. the local user
Dim startInfo As New ProcessStartInfo()
'Creates a secure string as the startInfo.Password parameter only accepts SecureStrings
Dim securePass As New Security.SecureString()
'You can't put a full string into a SecureString, so appending char by char
For Each c As Char In sPass
securePass.AppendChar(c)
Next
'Grab the file path
sPath = RetrieveFilePath()
'Load in the parameters for startInfo
startInfo.FileName = sPath
startInfo.UserName = sUser
startInfo.Password = securePass
startInfo.Domain = sDomain
startInfo.UseShellExecute = False
startInfo.WorkingDirectory = "\\Directory\Goes Here"
If File.Exists(sPath) Then
'Execute the process using startInfo
Process.Start(startInfo)
Else
MsgBox("File Not Found!")
End If
'Dispose of securePass
securePass.Dispose()
'Ends Impersonation
Impersonator.Undo()
End If
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
modGlobal.WriteToErrorLog(ex.Message, "frmActionEntry", modGlobal.GetExceptionInfo(ex), "frmActionEntry->btnOpenDoc_Click", currentUser.getEmployeeName())
End Try
End Sub
There are some interesting aspects to note here. You have to use a SecureString for the password when using ProcessStartInfo, and can only be assigned per character, and more importantly, I had to set UseShellExecute property to False.
I was hopeful that this would work, but after some iterations I got stuck on this error message:
Error Message Example
I figured out that this was due to being unable to access Windows Shell to find the default program to open the corresponding file type with, so it just expected an executable. After more research I was unable to find a clean way to get around this so I've decided to go about addressing this file upload a different way.
I know this is an old question, but maybe it can help someone else, I had the same problem and finally, realized that it's not enough to grant access to the impersonate user to read and write on the folder but also modify, if you don't, the user can not delete the file.
I need to do a one time download of a pipe deliminated text file in VBA. I have tried many of the solutions in other stack overflow questions but I can't seem to make any of the solutions work. It's from the internal wiki page of my firm.
The file is something like: https://wiki.somecompany/downloads/attachments/data.txt
Note: that is not a real url
Edit: I am working within excel.
I am extremely new to VBA, so the solutions I read will probably work but they were not idiot proof.
I tried many things, but the most promising looking were the solutions posted here: EXCEL VBA - To open a text file from a website
I stopped working with the first one because it seemed like you needed Mozilla for that one, and I did not know how to specify Chrome.
I messed around with the open workbook option, but I kept getting a compile error that said "Expected: =" but I don't know what the problem is or where it should be.
Edited: #Tim Williams - your solution is the closest to have anything at all happen besides just VBA errors. I got as far as turning my spreadsheet into a log in page, so I guess I need to pass a username and password somehow
You should be able to turn on the Macro Recorder and get what you want pretty quickly. In fact, you probably spent 10x more time describing the scenario, then it would take to record the code you need. Although, it is possible that you actually can't import the data using the Macro Recorder. You should still be able to import the data by referencing a CSV, which I believe is the exact same thing as a Text file.
Sub Import_CSV_File_From_URL()
Dim URL As String
Dim destCell As Range
URL = "http://www.test.com/test.csv"
Set destCell = Worksheets("test").Range("A1")
With destCell.Parent.QueryTables.Add(Connection:="TEXT;" & URL, Destination:=destCell)
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh BackgroundQuery:=False
End With
destCell.Parent.QueryTables(1).Delete
End Sub
If that doesn't work for you, simply download the file, and do the import from your hard-drive.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub DownloadFilefromWeb()
Dim strSavePath As String
Dim URL As String, ext As String
Dim buf, ret As Long
URL = Worksheets("Sheet1").Range("A2").Value
buf = Split(URL, ".")
ext = buf(UBound(buf))
strSavePath = "C:\Users\rshuell\Desktop\Downloads\" & "DownloadedFile." & ext
ret = URLDownloadToFile(0, URL, strSavePath, 0, 0)
If ret = 0 Then
MsgBox "Download has been succeed!"
Else
MsgBox "Error"
End If
End Sub
I would like to write a macro that will retrieve a file from our SharePoint and paste it in a special location for every user that runs the macro. I've used the following code to download the file
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub Button1_Click()
DownloadFileFromWeb = URLDownloadToFile(0,
"https://our.sharepoint.com/sharedFolder/file.pptx", "C:\Users\User\folder\myfile.pptx", 0, 0)
Debug.Print DownloadFileFromWeb
End Sub
Code from: How to download a file from Sharepoint with VBA
The value returned by URLDownloadFile is 0, but when I open the file PowerPoint is asking me to repair it. Ideally, I would like users to simply log into SharePoint and then use this macro to download a fresh copy of the shared file. My guess is that it has to do with authentication but I'm not sure how to solve this problem as I don't have much experience in this area. I would definitely not want to prompt for credentials and pass them on as plain text to a function nor do I want the user to hard code them somewhere. I would prefer for the user to sign in into SharePoint and the code to do the rest. Any help on the matter would be greatly appreciated.
EDIT:
I've also tried using the following code producing the same corrupt file. It looks like credentials may not be the problem.
Dim myURL As String
myURL = "https://our.sharepoint.com/sharedFolder/file.pptx"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send
myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile "C:\Users\User\folder\myfile.pptx", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
EDIT2:
I tried mapping the drive using various commands including net use and New-psdrive without any luck - I still fail to authenticate. Here's a PowerShell command and its output
net use S: '\\out.sharepoint.com/Shared Library' password /USER:me#domain.us
System error 1244 has occurred.
The operation being requested was not performed because the user has not
been authenticated.
I've got this issue yesterday and nothing seemed to work. So I added one row:
Workbooks.Open Filename:=myURL
after setting URL address and macro now works perfectly now.
I have a an Access App that requires the user to enter their Windows domain user and password to enter. I have used the following VBA code to accomplish this:
Function WindowsLogin(ByVal strUserName As String, ByVal strpassword As String, ByVal strDomain As String) As Boolean
'Authenticates user and password entered with Active Directory.
On Error GoTo IncorrectPassword
Dim oADsObject, oADsNamespace As Object
Dim strADsPath As String
strADsPath = "WinNT://" & strDomain
Set oADsObject = GetObject(strADsPath)
Set oADsNamespace = GetObject("WinNT:")
Set oADsObject = oADsNamespace.OpenDSObject(strADsPath, strDomain & "\" & strUserName, strpassword, 0)
WindowsLogin = True 'ACCESS GRANTED
ExitSub:
Exit Function
IncorrectPassword:
WindowsLogin = False 'ACCESS DENIED
Resume ExitSub
End Function
I notice that sometimes when the information is entered correctly, access is denied. I tried to debug once and it gave the error: "The network path was not found.
" on the Set oADsObject = oADsNamespace.OpenDSObject) line.
Not sure why this occurs sometimes. Is it better to convert to LDAP instead? I have tried but can't construct the LDAP URL correctly.
If the user is already authenticated via their Windows login, why make them enter the details again?
If you need to know which user is logged in, you can get the username very easily by the following function:
Declare Function IGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal sBuffer As String, lSize As Long) As Long
Function GetUserName() As String
On Error Resume Next
Dim sBuffer As String
Dim lSize As Long
Dim x As Long
sBuffer = Space$(32)
lSize = Len(sBuffer)
x = IGetUserName(sBuffer, lSize)
GetUserName = left$(sBuffer, lSize - 1)
End Function
In GxP environment it is additionally needed to enter at least password. It doesn't matter if You are logged to Windows, You need to confirm it again.
Wrote a small app that accesses a bunch of search websites and puts the results in a word document, which gets run a few hundred times a day.
It saves individual search results in a number of local folders so the next time those words are searched, it grabs them locally instead of loading the website again.
This works fine - even though it's not quick. People are impressed because until a few weeks ago they did this manually by literally loading up six different search websites, searching, and then copying and pasting the results in a word document.
However, our Office's internet is unreliable, and has been down the last half a day. This has meant about 400 bad searches have been saved in the local folders, and inserted into the final documents.
When a person was searching they could tell if the internet was broken and they would do their searches later. Obviously, though, this app can't tell, and because I'm not using APIs or anything, and because I am limited to using the VBA environment (I'm not even allowed MZ tools), I need to find some way to check that the internet is working before continuing with the program flow, without relying on too many references, and preferably without screenscraping for the phrase "404 Page Not Found".
I'm not very familiar with VB, and VBA is ruining me in so many ways, so there's probably some easy way to do this, which is why I'm asking here.
Appreciate any help.
Obviously, your problem has many levels. You should start by defining "connected to the internet", and go on with developing fallback strategies that include not writing invalid files on failure.
As for the "am I connected" question, you can try tapping into the Win32 API:
Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef dwflags As Long, ByVal dwReserved As Long ) As Long
Public Function GetInternetConnectedState() As Boolean
GetInternetConnectedState = InternetGetConnectedState(0&,0&)
End Function
Though depending on your network setup (proxy/NAT/firewall restrictions etc.), Windows might have a different opinion about this than you.
Trying to GET the pages you are interested in, checking on the return status in the HTTP headers (gateway timeout, 404, whatever you expect to happen when it "doen't work) might also be a way to go.
You could use MSXML library & use XMLHttpRequest class to check for things
e.g.
On Error Resume Next
Dim request As MSXML2.XMLHTTP60
request.Open "http://www.google.com"
request.Send
Msgbox request.Status
The status will give you HTTP Status code of what happened to the request.
You might have to do some more checks, depending on your scenario.
Hope that helps.
Use the following code to check for internet connection
first anable XML v6.0 in your references
Function checkInternetConnection() As Integer
'code to check for internet connection
'by Daniel Isoje
On Error Resume Next
checkInternetConnection = False
Dim objSvrHTTP As ServerXMLHTTP
Dim varProjectID, varCatID, strT As String
Set objSvrHTTP = New ServerXMLHTTP
objSvrHTTP.Open "GET", "http://www.google.com"
objSvrHTTP.setRequestHeader "Accept", "application/xml"
objSvrHTTP.setRequestHeader "Content-Type", "application/xml"
objSvrHTTP.Send strT
If err = 0 Then
checkInternetConnection = True
Else
MsgBox "Internet connection not estableshed: " & err.Description & "", 64, "Additt !"
End If
End Function
Unfortunately, this is a bit of a difficult question to answer for a couple of reasons:
How do you define a non-working internet connection? Do you check for a valid IP address? Do you ping out? How do you know that you have permissions to check these things? How do you know that the computer's firewall/antivirus isn't causing wonky behavior?
Once you've established that the connection is working, what do you do if the connection drops mid-operation?
There are probably ways to do what you want to do, but a lot of "devil's in the details" type things tend to pop up. Do you have any way to check that the saved search is valid? If so, that would probably be the best way to do this.
Building on shakalpesh's answer and the comments to it, there are (at least) two ways to get the web page into Word without parsing the XML returned by the XMLHTTP60 object.
(NB the HTTP status code of 200 indicates that "the request has succeeded" - see here)
write the XMLHTTP60.ResponseText out to a text file and then call Documents.Open on that text file
If (xhr.Status = 200) Then
hOutFile = FreeFile
Open "C:\foo.html" For Output As #hOutFile
Print #hOutFile, xhr.responseText
Close #hOutFile
End If
// ...
Documents.Open "C:\foo.html"
This has the disadvantage that some linked elements may be lost and you'll get a message box when the file opens
check the URL status with the XMLHTTP60 object and then use Documents.Open to open the URL as before:
If (xhr.Status = 200) Then
Documents.Open "http://foo.bar.com/index.html"
End If
There is a slight chance that the XMLHTTP60 request could succeed and the Documents.Open one fail (or vice versa). Hopefully this should be a fairly uncommon event though
I found most answers here and elsewhere confusing or incomplete, so here is how to do it for idiots like me:
'paste this code in at the top of your module (it will not work elsewhere)
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long
Private Const INTERNET_CONNECTION_MODEM As Long = &H1
Private Const INTERNET_CONNECTION_LAN As Long = &H2
Private Const INTERNET_CONNECTION_PROXY As Long = &H4
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
'paste this code in anywhere
Function IsInternetConnected() As Boolean
Dim L As Long
Dim R As Long
R = InternetGetConnectedState(L, 0&)
If R = 0 Then
IsInternetConnected = False
Else
If R <= 4 Then IsInternetConnected = True Else IsInternetConnected = False
End If
End Function
'your main function/calling function would look something like this
Private Sub btnInternetFunction_Click()
If IsInternetConnected() = True Then
MsgBox ("You are connected to the Internet")
'code to execute Internet-required function here
Else
MsgBox ("You are not connected to the Internet or there is an issue with your Internet connection.")
End If
End Sub
This is what I use. I prefer it because it doesn't require any external references or DLLs.
Public Function IsConnected()
Dim objFS As Object
Dim objShell As Object
Dim objTempFile As Object
Dim strLine As String
Dim strFileName As String
Dim strHostAddress As String
Dim strTempFolder As String
strTempFolder = "C:\PingTemp"
strHostAddress = "8.8.8.8"
IsConnected = True ' Assume success
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Wscript.Shell")
If Dir(strTempFolder, vbDirectory) = "" Then
MkDir strTempFolder
End If
strFileName = strTempFolder & "\" & objFS.GetTempName
If Dir(strFileName) <> "" Then
objFS.DeleteFile (strFileName)
End If
objShell.Run "cmd /c ping " & strHostAddress & " -n 1 -w 1 > " & strFileName, 0, True
Set objTempFile = objFS.OpenTextFile(strFileName, 1)
Do While objTempFile.AtEndOfStream <> True
strLine = objTempFile.Readline
If InStr(1, UCase(strLine), "REQUEST TIMED OUT.") > 0 Or InStr(1, UCase(strLine), "COULD NOT FIND HOST") > 0 Then
IsConnected = False
End If
Loop
objTempFile.Close
objFS.DeleteFile (strFileName)
objFS.DeleteFolder (strTempFolder)
' Remove this after testing. Function will return True or False
MsgBox IsConnected
End Function
I encourted this same problem and after googling a lot, I realized there was a simpler way to do it... It requires the user to enable the Microsoft Internet Explorer Controlers library, but that is all. The idea is that your code navigates to a website (in this case google), and after getting the webpage document (HTML). puts a value in the search box.
Sub Test1()
On Error GoTo no_internet 'Error handler when no internet
Dim IE As New SHDocVw.InternetExplorer
IE.Visible = False 'Not to show the browser when it runs
IE.navigate "www.google.com" 'navigates to google
Do While IE.ReadyState <> READYSTATE_COMPLETE 'loops until it is ready
Loop
'Here It gets the element "q" from the form "f" of the HTML document of the webpage, which is the search box in google.com
'If there is connection, it will run, quit and then go to the msgbox.
'If there is no connection, there will be an error and it will go to the error handler "no_internet" that is declared on top of the code
IE.document.forms("f").elements("q").Value = "test"
IE.Quit
MsgBox "Internet Connection: YES"
Exit Sub
no_internet:
IE.Quit
MsgBox "Internet Connection: NO" ' and here it will know that there is no connection.
End Sub