I have a legacy vba program that am trying to implement an software update functionality for. This will require me to copy the update from a location on our site and save temporary on the user system.
I have implemented the updater on the desktop but am having issue copying the patch from our site. I have tried some suggestion to use \oursite.com\folder\file.txt for example, but this has not worked for me as it is saying file not found.
downloadPaths(0) = "\\oursite.com\foldername\update\test.txt"
'once we have our folder in place, we will download the current update
' and save in the current local folder
If (IsArray(downloadPaths)) Then
' we will loop over each download patches to get from source
For Each updatepath In downloadPaths
If (updatepath <> "") Then
If (fs.FileExists(updatepath)) Then
' do whatever here
end if
end if
next
end if
Well as nobody attempt to answer this question, I have decided to post the solution I came up with. It is dirty, but it does get the job done, and the software update functionality is completed. Please note that in validating successful download, the response to check for will be determine by your server. I use Apache, Mysql, and Php 5 >.
Public Function downloadFileFromUrl(sourceUrl As Variant, destinationPath As Variant) As Boolean
On Error GoTo downloadFileFromUrlError
Dim validFile As Boolean
'It takes a url (sourceUrl) and downloads the URL to destinationPath.
With New WinHttpRequest
'Open a request to our source
.Open "GET", sourceUrl
'Set this to get it to go through the firewall
.SetAutoLogonPolicy AutoLogonPolicy_Always
.SetProxy 2, "http://127.0.0.1:8888", "*.never"
.SetRequestHeader "Accept", "*/*"
'Set any options you may need http://msdn.microsoft.com/en-us/library/windows/desktop/aa384108(v=vs.85).aspx
'Set a custom useragent, not needed, but could be useful if there are problems on the server
.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; VBA Wget)"
'Automatically follow any redirects
.Option(WinHttpRequestOption_EnableRedirects) = "True"
.Send
' check if the download is a valid file before we write to file
If (isValidFileDownload(.responseText)) Then
'Write the responseBody to a file
Dim ado As New ADODB.Stream
ado.Type = adTypeBinary
ado.Open
ado.Write .ResponseBody
ado.SaveToFile destinationPath, adSaveCreateOverWrite
ado.Close
downloadFileFromUrl = True 'download was successful
Else
downloadFileFromUrl = False 'download was not successful
End If
End With
downloadFileFromUrlExit:
On Error Resume Next
Set ado = Nothing
Exit Function
downloadFileFromUrlError:
downloadFileFromUrl = False 'An error occurred
Select Case Err
Case Else
Debug.Print "Unhandled Error", Err.Number, Err.description, Err.Source, Erl()
End Select
Resume downloadFileFromUrlExit
Resume
End Function
Private Function isValidFileDownload(responseText As Variant) As Boolean
On Error Resume Next
If (InStr(1, left(responseText, 1000), "<h1>Object not found!</h1>")) Then
Exit Function
Else
isValidFileDownload = True
End If
End Function
Related
I used the code provided by Siddharth Rout in the following threat.
Detect whether Excel workbook is already open
My goal was to check if a certain named workbook was open and depending on the result perform certain actions.
This was the result.
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
The following piece refers back to the function and depending on the result performs certain actions.
Dim xls As Object
Dim Answer As String
Dim Mynote As String
If IsWorkBookOpen(Environ("USERPROFILE") & "\Desktop\Report.xlsm") =
True Then
Mynote = "The Report is still open. Do you want to save the Report ?"
Answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Warning Report open")
If Answer = vbYes Then
MsgBox "Please Save your Report under a new name and close it. then press update again"
Exit Sub
Else
Set xls = GetObject(Environ("USERPROFILE") & "\Desktop\Report.xlsm")
xls.Close True
End If
Else
End If
This used to work perfectly in the past but since today it suddenly gives me error 53.
While trying to resolve the issue I discovered the error only occurs when the named workbook is not on the desktop. Strangely enough it did not have this issue in the past. I specifically tested that because the file will not always be on the desktop.
I tried several backups tracking back 2 months and even those show the same error now.
While searching the internet for this issue i found this thread,
Check if excel workbook is open?
where they suggest to change the following pieces,
(ErrNo = Err) in to (Errno = Err.Number)
(ff = FreeFile_()) in to (ff = FreeFile)
I did both together and independitly. eventhough i dont really see the relation between the error and Freefile.
This did not change the error at all.
While I am currious to why this error suddenly occurs I really do need a solution or alternative.
what i need it tot do again is,
- Check if named workbook is open.
- when it is open a Msgbox with yes and no option should appear.
- On "No" it should close the named workbook and continue with whatever is below of what i posted.
- On yes it should pop a message box and stop.
Any help that can be provided will be highly appreciated.
You need to check if the file exists before checking if it is open;
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
' bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Dim lngAttributes As Long
'Include read-only files, hidden files, system files.
lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
If bFindFolders Then
lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
Else
'Strip any trailing slash, so Dir does not look inside the folder.
Do While Right$(strFile, 1) = "\"
strFile = Left$(strFile, Len(strFile) - 1)
Loop
End If
'If Dir() returns something, the file exists.
On Error Resume Next
FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
I'm trying to implement a certain feature in the Microsoft Access Database using VBA, so when a certain button is pressed, it will check first the availability of the folder in a server. If the folder doesn't exist, the corresponding folder will be created. However, the folders have permissions attached to them, which means only certain users can access it, and hence only certain users should create / access the folder. I have tried the following:
on error resume next
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
End If
But I'm not sure if it's the best way to handle this problem. I use the "On Error Resume Next", so that if the error occurs due to the lack of permission to the folder (that already exists), it will ignore it. What are some better ways to handle this? Thank you.
I also have checked the following links:
https://social.msdn.microsoft.com/Forums/office/en-US/a79054cb-52cf-48fd-955b-aa38fd18dc1f/vba-verify-if-user-has-permission-to-directory-before-saveas-attempt?forum=exceldev
Check Folder Permissions Before Save VBA
but both of them concerns with saving the file, not creating folder.
After several days without success, finally I found the solution:
Private function canAccess(path as string) as boolean
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
Dim result As Integer
Dim command As String
command = "icacls " & """" & pfad & """"
result = oShell.Run(command, 0, True)
'Check privilege; file can be accessed if error code is 0.
'Else, errors are encountered, and error code > 0.
If result <> 5 and result <> 6 Then
KannAufDateiZugreifen = True
Else
KannAufDateiZugreifen = False
End If
end function
private sub button_click()
if canAccess ("Server/Data/Celes") then
If Dir("Server/Data/Celes", vbDirectory) = "Celes" Then
Else
MkDir ("Server/Data/Celes")
end if
End If
end sub
The function "canAccess" will simulate the running of the Windows shell, and execute "icacls" to see if the file can be accessed or not. If the function returns true, it means the "icacls" command is successful, which means the folder can be accessed. Otherwise, the file / folder can not be accessed.
I'm pretty sure this can be improved, but for now, it works.
I use the below function that recursively creates the full path (if required) and returns a value indicating success or failure. It works also with UNCs.
Private Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'checks for existence of a folder and create it at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")
Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String
If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
Set fs = CreateObject("Scripting.FileSystemObject")
'UNC path ? change 3 "\" into 3 "#"
If sPath Like "\\*\*" Then
sPath = Replace(sPath, "\", "#", 1, 3)
End If
'now split
FolderArray = Split(sPath, "\")
'then set back the # into \ in item 0 of array
FolderArray(0) = Replace(FolderArray(0), "#", "\", 1, 3)
On Error GoTo hell
'start from root to end, creating what needs to be
For i = 0 To UBound(FolderArray) Step 1
Folder = Folder & FolderArray(i) & "\"
If Not fs.FolderExists(Folder) Then
fs.CreateFolder (Folder)
End If
Next
CreateFolder = True
hell:
End Function
'Must set a Reference to the Microsoft Scripting Runtime
Dim fso As FileSystemObject
Dim fil As File
Set fso = New Scripting.FileSystemObject
If fso.FileExists("\\serverName\folderName\fileName.txt") Then
'code execution here
Else
MsgBox "File and/or Path cannot be found", vbCritical, "File Not Found"
End If
I am opening a workbook from Access via VBA using the following code. I need to check whether that workbook is already open: if already open then do nothing, otherwise open it with CreateObject method. Code is as below:
Dim oAppa As Object
Dim filea As String
filea = CurrentProject.Path & "\List.xlsm"
Set oAppa = CreateObject("Excel.Application")
oAppa.Visible = True
Set owb_a = oAppa.workbooks.Open(filea, ReadOnly:=True)
Here while opening it, I need to check whether it's already opened. Please help me out, Thanks in advance.
You could loop through all open workbooks, but this would take a while...
A simple solution, taken from https://stackoverflow.com/a/9373914/2829009
Option Explicit
Sub Sample()
Dim Ret
Ret = IsWorkBookOpen("C:\myWork.xlsx")
If Ret = True Then
MsgBox "File is open"
Else
MsgBox "File is Closed"
End If
End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
I just answered a near identical question about Word. The answer would be the same (or very similar):
' Handle Error In-Line
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number = 429 Then
'If we got an error, that means there was no Excel Instance
Set objExcel = CreateObject("Excel.Application")
Else
Msgbox ("You're going to need to close any open Excel docs before you can perform this function.", vbOK)
Exit Sub
End If
'Reset Error Handler
On Error GoTo 0
Of course, you can tweak what you want to do if the instance already exists, rather than just exiting the Sub.
I have an MS Access 2007 VBA application running on Windows 7. One crucial function is to upload files to a WebDAV server. The code below works perfectly on one PC, but fails on other PCs (and yes, each is configured the same way).
Here is a translate.google.com translation of the Norwegion error message that pops up when it fails on the other PCs:
Run-time error '-2147217895 (80040e19)': can not find any objects or data in accordance with the name, range or selection criteria within the scope of this operation
It fails on this line of code:
objRecord.Open fil, "URL=" & URL, adModeReadWrite, adCreateOverwrite, adDelayFetchStream, sUsername, sPwd
The full function code is below. It's really just reuse of the code at http://social.msdn.microsoft.com/Forums/en-US/isvvba/thread/26b8e905-33d0-438b-98a7-bb69053b931e/. Any hints would be greatly appreciated!
Function DAVPUT(ByVal URL As String, ByVal fil As String) As Boolean '
Dim sUsername As String
Dim sPwd As String
sUsername = "k#dummy.com"
sPwd = "dummy"
Dim objRecord As New ADODB.Record
Dim objStream As New ADODB.Stream
objRecord.Open fil, "URL=" & URL, adModeReadWrite, adCreateOverwrite, adDelayFetchStream, sUsername, sPwd
objStream.Type = adTypeBinary
objStream.Open objRecord, adModeWrite, adOpenStreamFromRecord
objStream.LoadFromFile fil
objStream.Flush
DoEvents
objStream.close
objRecord.close
DAVPUT = True
End Function
This post suggests you "compare the versions of MDAC local and remote". I realize I am offering a minimal, inexpert answer, but since there are not others, here it is.
Are there ways in Access VBA (2003) to cast a COM reference to an integer, and to call AddRef/Release? (which give the error "Function or interface marked as restricted, or the function uses an Automation type not supported in Visual Basic")
I'm using a third-party COM object which doesn't handle being instantiated twice in a single process (this is a known bug). I therefore thought of storing the reference as the caption of a control on a hidden form to protect it from Program Reset clearing all VB variables.
Edit: I think the cast to int can be done with the undocumented ObjPtr, and back again with the CopyMemory API, and AddRef/Release can be called implicitly. But is there a better way? Are add-ins protected from Program Reset?
Is the problem with surviving the code reset or is it that once the code is reset it can't be re-initialized?
For the first problem, wrap your top-level object in a function and use a STATIC variable internally to cache the reference. If the STATIC variable Is Nothing, re-initialize. Here's the function I use for caching a reference to the local database:
Public Function dbLocal(Optional bolInitialize As Boolean = True) +
As DAO.Database
' 2003/02/08 DWF added comments to explain it to myself!
' 2005/03/18 DWF changed to use Static variable instead
' uses GoTos instead of If/Then because:
' error of dbCurrent not being Nothing but dbCurrent being closed (3420)
' would then be jumping back into the middle of an If/Then statement
On Error GoTo errHandler
Static dbCurrent As DAO.Database
Dim strTest As String
If Not bolInitialize Then GoTo closeDB
retryDB:
If dbCurrent Is Nothing Then
Set dbCurrent = CurrentDb()
End If
' now that we know the db variable is not Nothing, test if it's Open
strTest = dbCurrent.Name
exitRoutine:
Set dbLocal = dbCurrent
Exit Function
closeDB:
If Not (dbCurrent Is Nothing) Then
Set dbCurrent = Nothing
End If
GoTo exitRoutine
errHandler:
Select Case err.Number
Case 3420 ' Object invalid or no longer set.
Set dbCurrent = Nothing
If bolInitialize Then
Resume retryDB
Else
Resume closeDB
End If
Case Else
MsgBox err.Number & ": " & err.Description, vbExclamation, "Error in dbLocal()"
Resume exitRoutine
End Select
End Function
Anywhere you'd either of these in code:
Dim db As DAO.Database
Set db = CurrentDB()
Set db = DBEngine(0)(0)
db.Execute "[SQL DML]", dbFailOnError
...you can replace the whole thing with:
dbLocal.Execute "[SQL DML]", dbFailOnError
...and you don't have to worry about initializing it when your app opens, or after a code reset -- it's self-healing because it checks the Static internal variable and re-initializes if needed.
The only caveat is that you need to make a call with the bolInitialize argument set to False when you shut down your app, as this cleans up the reference so there's no risk of your app hanging when it goes out of scope as the app closes.
For the other problem, I really doubt there's any solution within VBA, unless you can make an API call and kill the external process. But that's something of a longshot, I think.