fso.CopyFile Stopped working in MS Access DB - vba

I have the following code I have been using for a good year now. I tried to use it today and keep getting permission denied. I have not changed anything and have been gone for from work for 2w. I have checked everything as well as uninstalled the security fixes from mid December but still doesn't work anymore. This is a button in my MS Access db that backs up the current DB. I am using MS365.
Public Function DBBackup()
Dim fso As FileSystemObject
Dim sSourcePath As String
Dim sSourceFile As String
Dim sBackupPath As String
Dim sBackupFile As String
sSourcePath = "W:\Analysis Check\My Data\"
sSourceFile = "Weekly Chronics DB.accdb"
sBackupPath = "W:\Analysis Check\My Data\"
sBackupFile = "Weekly Chronics DB_" & Format(Date, "mmddyyyy") & ".accdb"
Set fso = New FileSystemObject
fso.CopyFile sSourcePath & sSourceFile, sBackupPath & sBackupFile, True
Set fso = Nothing
Beep
MsgBox "Backup was successful", vbInformation, "Backup Completed"
End Function

Check to be sure the source file is not locked
another possible cause is
destination folder having permission issue.

Related

How Do I Automatically Update the ChromeDriver or EdgeDriver in VBA?

I have searched the web for a solution to "auto-update" my Selenium EdgeDriver automatically. For those who use SeleniumBasic, you know it can be a hassle to manually download the driver from the respective webpage every so often when your main Host browser gets a major update.
In my web searching, I have found support for other languages to "auto-update" their versions of these drivers, but VBA, as usual, was lacking support.
Now I don't claim this to be the perfect solution, but it at least works. The problem I can see in the future is that layouts of each respective webpage may change, so I do welcome updates if this is the case and I will try to update as well. But for the most part, it should just work.
While this is a Self-Answered question, I absolutely would love to see other methods posted here for myself and other users to try out. SeleniumBasic is a good tool for certain applications, but often lacks community support as VBA is not as widely used in the community as other languages - at least not on a more sophisticated level.
I should start out by saying that I am only supporting Chrome and Edge drivers for the time being. But if you can follow along, you might be able to add your own support for any of the other SeleniumBasic-supported WebDrivers.
Before we get started, it is important to enable the following References by going to Tools > References within the VBE:
Next, you need to create a Class Module named SeleniumWebDriver.
I decided to make this a Class Object because I intend to build a little on it in the future. You may add your own Properties and functions as you wish, but the code being provided will only allow updating the WebDrivers, at least for now.
Here is the complete Class Module Code:
Option Explicit
Rem Did Chrome change their file url and break your code?
' Check for an update: https://stackoverflow.com/a/67996166/5781745
Private ChromeDriver As Selenium.ChromeDriver
Private EdgeDriver As Selenium.EdgeDriver
Private SeleniumFolder As String
Private TempZipFile As String
Private ChromeInit As Boolean, EdgeInit As Boolean
Public Enum dType
Chrome
Edge
End Enum
Public Property Get SeleniumFolderPath() As String
SeleniumFolderPath = SeleniumFolder
End Property
Public Property Let SeleniumFolderPath(ByVal FolderPath As String)
SeleniumFolder = FolderPath
End Property
Public Sub UpdateDriver(ByVal DriverType As dType)
'URLs to the drivers' home pages to which we can grab the curr versions
Dim URLPath As String
Select Case DriverType
Case dType.Chrome
URLPath = "https://chromedriver.chromium.org/home"
Case dType.Edge
URLPath = "https://developer.microsoft.com/en-us/microsoft-edge/tools/webdriver/"
End Select
'Grab the current Version # from the driver's webpage
Dim Doc As New HTMLDocument, DriverVer As String
With New MSXML2.XMLHTTP60
.Open "GET", URLPath
.send
Doc.body.innerHTML = .responseText
End With
DriverVer = getCurrentVersion(Doc, DriverType)
DownloadUpdatedDriver DriverVer, DriverType
ExtractZipAndCopy DriverType
End Sub
' For use in a later project. Not needed at this time
Private Sub InitializeDriver(ByVal DriverType As dType)
Select Case DriverType
Case dType.Chrome
Set ChromeDriver = New Selenium.ChromeDriver
ChromeDriver.Start
ChromeInit = True
Case dType.Edge
Set EdgeDriver = New Selenium.EdgeDriver
EdgeDriver.Start
EdgeInit = True
End Select
End Sub
Private Function getCurrentVersion(Doc As HTMLDocument, DriverType As dType) As String
Dim div As HTMLDivElement
Select Case DriverType
Case dType.Chrome
For Each div In Doc.getElementsByTagName("p")
If div.innerText Like "Latest stable release*" Then
With New VBScript_RegExp_55.RegExp
.Pattern = "ChromeDriver\s([\d\.]+)\b"
getCurrentVersion = .Execute(div.innerText)(0).SubMatches(0)
Exit Function
End With
End If
Next
Case dType.Edge
With New VBScript_RegExp_55.RegExp
.Pattern = "Version:\s([\d\.]+)"
For Each div In Doc.getElementsByClassName("module")(0).getElementsByTagName("p")
If .test(div.innerText) Then
getCurrentVersion = .Execute(div.innerText)(0).SubMatches(0)
Exit Function
End If
Next
End With
End Select
End Function
Private Sub DownloadUpdatedDriver(ByVal CurrVersion As String, DriverType As dType)
Dim URLPath As String
Select Case DriverType
Case dType.Chrome
URLPath = "https://chromedriver.storage.googleapis.com/" & CurrVersion & "/chromedriver_win32.zip"
Case dType.Edge
Kill Environ$("LocalAppData") & "\SeleniumBasic\Driver_Notes\*.*"
URLPath = "https://msedgedriver.azureedge.net/" & CurrVersion & "/edgedriver_win64.zip"
End Select
Dim FileStream As New ADODB.Stream
With New MSXML2.XMLHTTP60
.Open "GET", URLPath
.send
FileStream.Open
FileStream.Type = adTypeBinary
FileStream.Write .responseBody
FileStream.SaveToFile TempZipFile, adSaveCreateOverWrite
FileStream.Close
End With
End Sub
Private Sub ExtractZipAndCopy(ByVal DriverType As dType)
Dim FileName As String
Select Case DriverType
Case dType.Chrome: FileName = "\chromedriver.exe"
Case dType.Edge: FileName = "\edgedriver.exe"
End Select
'Delete the old WebDriver
Kill SeleniumFolder & FileName
'Copy the new driver from .zip file to SeleniumBasic folder
Dim oShell As New shell
oShell.Namespace(SeleniumFolder).CopyHere oShell.Namespace(TempZipFile).Items
'Selenium VBA expects 'edgedriver' for edge, but new drivers are named 'msedgedriver'.
'If we are updating Edge, we need to rename the file
If DriverType = dType.Edge Then
Name SeleniumFolder & "msedgedriver.exe" As SeleniumFolder & "edgedriver.exe"
End If
'Delete the temporary zip file
Kill TempZipFile
End Sub
Private Sub Class_Initialize()
' Set the default file path. Can be modified later using ChromeDriverPath property
SeleniumFolder = Environ$("LocalAppData") & "\SeleniumBasic\"
TempZipFile = Environ$("LocalAppData") & "\Temp\WebDriver.zip"
End Sub
Now that you've created your Selenium Class, you can now use it in a standard module such as:
Important Tip: I am not sure if there is a delay between when you update your web browser and when the drivers are officially released. Therefore before updating your driver, I would put some error handling to see if Selenium throws an error first. If the driver does not match the browser version, Selenium will throw error # 33. If you check for this error, you should be safe to go ahead and update the WebDriver at this point. What we want to prevent is that you update your driver before your browser is automatically updated, causing mismatching versions.
It is also possible that your browser may update and the Selenium driver hasn't been released yet - but unfortunately that is not something that we can control.
The remainder of this answer will just go into some detail as to what it's doing. If you don't care, you may leave now.
First, as with any other object, we have to initialize it. In the above example, we do that with the With New SeleniumWebDriver statement. This fires the Class_Initialize() event here:
Private Sub Class_Initialize()
' Set the default file path. Can be modified later using ChromeDriverPath property
SeleniumFolder = Environ$("LocalAppData") & "\SeleniumBasic\"
TempZipFile = Environ$("LocalAppData") & "\Temp\WebDriver.zip"
End Sub
The purpose of this is to set the default file paths for the SeleniumBasic folder and temp file. However, if your folder is somewhere else, this class has a property to which you can change the folder manually. Just use the ClassObj.SeleniumFolderPath() property to establish your new path.
The TempZipFile is a class-scoped variable that will store the .zip file you download from the respective websites.
Upon calling the UpdateDriver method, the class will place a GET request to the respective driver's webpage, then grab the current version # from the page. It will then pass this driver version to the DownloadUpdatedDriver routine, which stores the download links for each respective driver. For Chrome, the link is: https://chromedriver.storage.googleapis.com/<Version#>/chromedriver_win32.zip, and for Edge it's: https://msedgedriver.azureedge.net/<Version#>/edgedriver_win64.zip. It's important to realize that if you happen to be using the 32 bit version of Edge, you will need to change the URL to edgedriver_win32.zip. This routine downloads the .zip file to your local AppData's Temp Folder.
After the file has been downloaded, we then proceed to call the ExtractZipAndCopy routine. This simply extracts the .exe files to the Selenium Folder, first deleting the old file. Edge does a little extra maintenance work, but you're now essentially updated!
I hope this helps someone out there who is annoyed as I am having to periodically update these drivers and was wanting an automated solution. Please feel free to edit this answer if minor changes are needing to be made, such as if a URL is broken.
There is now an API to check Latest Release of ChromeDriver. So the code can become shorter. Also, adding a functionality to run the update only if the current chrome version does not match installed chromedriver version. And to copy using administrator rights.
I am not using Edge so that code functionality is not there in my code.
Function chkchromever()
Tempfolder = "D:\"
TempZipFile = Tempfolder & "Chromedriver.zip"
SeleniumFolder = Environ$("ProgramW6432") & "\SeleniumBasic\"
TempDrvFile = Tempfolder & "Chromedriver.exe"
'Delete chromedriver.exe from temporary folder if it already exists
If Dir(TempDrvFile) <> "" Then
Kill (TempDrvFile)
End If
Dim oShell As New WshShell
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'Get chrome version
chrversion = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Google\Chrome\BLBeacon\version")
dotsarr = Split(chrversion, ".")
leftchrver = dotsarr(0) & dotsarr(1)
'Get chromedriver version
gspath = Chr(34) & SeleniumFolder & "chromedriver.exe" & Chr(34)
torun = gspath & " --version"
errcode = oShell.Exec(torun).StdOut.ReadAll
verarr = Split(errcode, " ")
chrdrv = verarr(1)
dotsarr2 = Split(chrdrv, ".")
leftchrdrv = dotsarr(0) & dotsarr(1)
'If major version mismatch (first two numbers) then ask if update required
If leftchrver <> leftchrdrv Then
myyn = MsgBox("Wrong version of chromedriver. " & vbCrLf & "Chrome version is " & chrversion & vbCrLf & "Chrome driver version is " & chrdrv, vbYesNo, "Do you want to update Chromedriver ?")
If myyn = vbNo Then Exit Function
'Get latest release version of chromedriver which matches installed version of Chrome
url = "https://chromedriver.storage.googleapis.com/LATEST_RELEASE_" & dotsarr(0)
Call objHttp.Open("GET", url, False)
Call objHttp.send("")
version_number = objHttp.responseText
dotsarr3 = Split(version_number, ".")
leftversion_no = dotsarr3(0) & dotsarr3(1)
If leftchrver = leftversion_no Then
'If chromedriver found then download it
download_url = "https://chromedriver.storage.googleapis.com/" + version_number + "/chromedriver_win32.zip"
Call objHttp.Open("GET", download_url, False)
Call objHttp.send("")
Set fileStream = New ADODB.Stream
With fileStream
.Open
.Type = adTypeBinary
.Write objHttp.responseBody
.Position = 0
.SaveToFile TempZipFile, adSaveCreateOverWrite
.Close
End With
'Copy the new driver from .zip file to SeleniumBasic folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(Tempfolder).CopyHere oApp.Namespace(TempZipFile).Items
'Create batch file to copy chromedriver.exe to Seleniumbasic folder and run it using Administrator rights
tmpbatpath = Tempfolder & "copychdrv.bat"
'Check if Chromedriver downloaded successfully
If Dir(TempDrvFile) <> "" Then
Open tmpbatpath For Output As #1
'Enable these if required to copy chromedriver.exe
' Print #1, "taskkill /f /im GoogleCrashHandler.exe"
' Print #1, "taskkill /f /im GoogleCrashHandler64.exe"
' Print #1, "taskkill /f /im Chrome.exe"
' Print #1, "taskkill /f /im Googleupdate.exe"
If IsProcessRunning("Chromedriver.exe") Then
Print #1, "taskkill /f /im Chromedriver.exe"
End If
Print #1, "copy " & Chr(34) & TempDrvFile & Chr(34) & " " & Chr(34) & SeleniumFolder & "Chromedriver.exe" & Chr(34) & "/y"
Close #1
'copy it now by running batch file
success = ShellExecute(0, "runas", tmpbatpath, aPic, vbNullString, SW_SHOWNORMAL)
End If
'Cleanup
If Dir(TempZipFile) <> "" Then
Kill (TempZipFile)
End If
If Dir(tmpbatpath) <> "" Then
Kill (tmpbatpath)
End If
End If
End If
End Function
As i am on a company PC, I updated the code to work on a locked PC
Option Explicit
'**********************************************************
' PUBLIC FUNCTION
'/
'**********************************************************
' #Fn chkchromever
'
' #brief Check if Selenium Crome Driver is up to date or update it
'
' #param checks Crome version and Installed and availible Driver for Selenium
'
' #SUBs IsProcessRunning, ShellExecute
'
' Librarys Selenium Type library
' Windows Script Host Object Model - Dim oShell As New WshShell ,
' Microsoft ActiveX Data Objects 6.1 Library - Set fileStream = New ADODB.Stream
'
' #return new driver
'/
Public Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal Hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Function chkchromever()
Dim tempfolder As Variant, TempZipFile As Variant
Dim SeleniumFolder As String, TempDrvFile As String
Dim chrversion As String, leftchrver As String
Dim dotsarr() As String
Dim gspath As String, torun As String, errcode As String
Dim verarr() As String, chrdrv As String, leftchrdrv As String
Dim dotsarr2() As String
Dim myyn As Integer
Dim Url As String, version_number As String, leftversion_no As String
Dim dotsarr3() As String
Dim download_url As String
tempfolder = "C:\Temp\"
TempZipFile = tempfolder & "Chromedriver.zip"
'SeleniumFolder = Environ$("ProgramW6432") & "\SeleniumBasic\"
SeleniumFolder = Environ$("LOCALAPPDATA") & "\SeleniumBasic\"
TempDrvFile = tempfolder & "Chromedriver.exe"
'Delete chromedriver.exe from temporary folder if it already exists
If Dir(TempDrvFile) <> "" Then
Kill (TempDrvFile)
End If
Dim oShell As New WshShell
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'Get chrome version
chrversion = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Google\Chrome\BLBeacon\version")
dotsarr = Split(chrversion, ".")
leftchrver = dotsarr(0) & dotsarr(1)
'Get chromedriver version
gspath = Chr(34) & SeleniumFolder & "chromedriver.exe" & Chr(34) ' chr34 er gåseøjne
torun = gspath & " --version"
errcode = oShell.Exec(torun).StdOut.ReadAll
verarr = Split(errcode, " ")
chrdrv = verarr(1)
dotsarr2 = Split(chrdrv, ".")
leftchrdrv = dotsarr2(0) & dotsarr2(1)
'If major version mismatch (first two numbers) then ask if update required
If leftchrver <> leftchrdrv Then
myyn = MsgBox("Wrong version of chromedriver. " & vbCrLf & "Chrome version is " & chrversion & vbCrLf & "Chrome driver version is " & chrdrv, vbYesNo, "Do you want to update Chromedriver ?")
If myyn = vbNo Then Exit Function
'Get latest release version of chromedriver which matches installed version of Chrome
Url = "https://chromedriver.storage.googleapis.com/LATEST_RELEASE_" & dotsarr(0)
Call objHttp.Open("GET", Url, False)
Call objHttp.send("")
version_number = objHttp.responseText
dotsarr3 = Split(version_number, ".")
leftversion_no = dotsarr3(0) & dotsarr3(1)
If leftchrver = leftversion_no Then
'If chromedriver found then download it
download_url = "https://chromedriver.storage.googleapis.com/" + version_number + "/chromedriver_win32.zip"
Call objHttp.Open("GET", download_url, False)
Call objHttp.send("")
Dim fileStream As Object
Set fileStream = New ADODB.Stream
With fileStream
.Open
.Type = adTypeBinary
.Write objHttp.responseBody
.Position = 0
.SaveToFile TempZipFile, adSaveCreateOverWrite
.Close
End With
'unzip file
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tempfolder).CopyHere oApp.Namespace(TempZipFile).Items
'Check if Chromedriver downloaded successfully
If Dir(TempDrvFile) <> "" Then
If IsProcessRunning("Chromedriver.exe") Then
Shell "cmd /c""" & "taskkill /f /im Chromedriver.exe"
End If
'Copy / Overwrite file in SeleniumBasic folder
FileCopy TempDrvFile, SeleniumFolder & "Chromedriver.exe"
End If
'Cleanup
If Dir(TempZipFile) <> "" Then
Kill (TempZipFile)
End If
If Dir(TempDrvFile) <> "" Then
Kill (TempDrvFile)
End If
End If
End If
End Function
Function IsProcessRunning(process As String)
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & process & "'")
IsProcessRunning = objList.Count > 0
End Function
I had to modify the code posted above by Jesper Martin Schumacher as our IT department has updated all Office Applications to 64-bit.
That code was failing on instances of "New" keyword, so I researched and found:
compile error User-defined type not defined at "oShell As WshShell"
The suggestion there was to use "Late Binding" CreateObject method instead, as below.
Set oShell = CreateObject("WScript.Shell") 'Had to edit this line. It WAS "Set oShell = New WshShell"
Set fileStream = CreateObject("ADODB.Stream") 'Had to edit this line. It WAS "Set fileStream = New ADODB.Stream"

Visual Basic, Capture output from cmd

Sorry if it's asked before, I found out other Solutions too complicated for me..
Anyway, i am trying to search an image via cmd in visual basic code, and save the image path to string, but i cant seem to capture the output from cmd right.
Any help will be appreciated, thanks!.
Code:
Dim imageLocation As String
Dim cmd As New Process
Dim SR As System.IO.StreamReader
cmd.StartInfo.FileName = "cmd.exe"
cmd.StartInfo.WindowStyle = ProcessWindowStyle.Hidden
cmd.StartInfo.Arguments = "/C dir /b/s Roey.png"
cmd.Start()
SR = cmd.StandardOutput
imageLocation = SR.ReadLine
UPDATED So i found out saving the output to txt file and then read it can be more simple, so i wrote the following code:
Dim cmd As New Process
cmd.StartInfo.FileName = "cmd.exe"
cmd.StartInfo.WindowStyle = ProcessWindowStyle.Hidden
cmd.StartInfo.Arguments = "/C dir /b/s Roey.png >
C:\Users\ירין\Desktop\Roeyyy\path.txt"
cmd.Start()
cmd.WaitForExit()
when i run the
"dir /b/s Roey.png >
C:\Users\ירין\Desktop\Roeyyy\path.txt"
on CMD it wors perfectly, so why isnt it working here? :(
I found this:
Dim MyFilePath As String = Directory.GetFiles([SomePath], "*.png", SearchOption.AllDirectories).
Where(Function(f) f.Contains("Roey.png")).FirstOrDefault()
Solved!
You are a programmer so you search for files.
Imports System.Runtime.InteropServices
Sub Main
'On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Dirname = InputBox("Enter Dir name")
ProcessFolder DirName
End Sub
Sub ProcessFolder(FolderPath)
On Error Resume Next
Set fldr = fso.GetFolder(FolderPath)
Set Fls = fldr.files
For Each thing in Fls
msgbox Thing.Name & " " & Thing.path
'fso.copyfile thing.path, "C:\backup"
Next
Set fldrs = fldr.subfolders
For Each thing in fldrs
ProcessFolder thing.path
Next
End Sub

Microsoft Excel Data Connections - Alter Connection String through VBA

I have a fairly straightforward question. I am trying to find a way to alter and change a connection string for an existing data connection in an excel workbook through VBA (macro code). The main reason I am trying to do this is to find a way to prompt the user that opens up the workbook to enter their credentials (Username/Password) or have a checkbox for Trusted Connection that would be used in the Connection String of those existing data connections.
Right now the Data connections are running off a sample user that I created and that needs to go away in the production version of the workbook. Hope that makes sense?
Is this possible? If yes, could you please give me a sample/example code block? I would really appreciate any suggestions at this point.
I also had this exact same requirement and although the duplicate question Excel macro to change external data query connections - e.g. point from one database to another was useful, I still had to modify it to meet the exact requirements above. I was working with a specific connection, while that answer targeted multiple connections. So, I've included my workings here. Thank you #Rory for his code.
Also thanks to Luke Maxwell for his function to search a string for matching keywords.
Assign this sub to a button or call it when the spreadsheet is opened.
Sub GetConnectionUserPassword()
Dim Username As String, Password As String
Dim ConnectionString As String
Dim MsgTitle As String
MsgTitle = "My Credentials"
If vbOK = MsgBox("You will be asked for your username and password.", vbOKCancel, MsgTitle) Then
Username = InputBox("Username", MsgTitle)
If Username = "" Then GoTo Cancelled
Password = InputBox("Password", MsgTitle)
If Password = "" Then GoTo Cancelled
Else
GoTo Cancelled
End If
ConnectionString = GetConnectionString(Username, Password)
' MsgBox ConnectionString, vbOKOnly
UpdateQueryConnectionString ConnectionString
MsgBox "Credentials Updated", vbOKOnly, MsgTitle
Exit Sub
Cancelled:
MsgBox "Credentials have not been changed.", vbOKOnly, MsgTitle
End Sub
The GetConnectionString function stores the connection string that you insert your username and password into. This one is for an OLEDB connection and is obviously different depending on the requirements of the Provider.
Function GetConnectionString(Username As String, Password As String)
Dim result As Variant
result = "OLEDB;Provider=Your Provider;Data Source=SERVER;Initial Catalog=DATABASE" _
& ";User ID=" & Username & ";Password=" & Password & _
";Persist Security Info=True;Extended Properties=" _
& Chr(34) & "PORT=1706;LOG=ON;CASEINSENSITIVEFIND=ON;INCLUDECALCFIELDS=ON;" & Chr(34)
' MsgBox result, vbOKOnly
GetConnectionString = result
End Function
This code does the job of actually updating a named connection with your new connection string (for an OLEDB connection).
Sub UpdateQueryConnectionString(ConnectionString As String)
Dim cn As WorkbookConnection
Dim oledbCn As OLEDBConnection
Set cn = ThisWorkbook.Connections("Your Connection Name")
Set oledbCn = cn.OLEDBConnection
oledbCn.Connection = ConnectionString
End Sub
Conversely, you can use this function to get whatever the current connection string is.
Function ConnectionString()
Dim Temp As String
Dim cn As WorkbookConnection
Dim oledbCn As OLEDBConnection
Set cn = ThisWorkbook.Connections("Your Connection Name")
Set oledbCn = cn.OLEDBConnection
Temp = oledbCn.Connection
ConnectionString = Temp
End Function
I use this sub to refresh the data when the workbook is opened but it checks that there is a username and password in the connection string before doing the refresh. I just call this sub from the Private Sub Workbook_Open().
Sub RefreshData()
Dim CurrentCredentials As String
Sheets("Sheetname").Unprotect Password:="mypassword"
CurrentCredentials = ConnectionString()
If ListSearch(CurrentCredentials, "None", "") > 0 Then
GetConnectionUserPassword
End If
Application.ScreenUpdating = False
ActiveWorkbook.Connections("My Connection Name").Refresh
Sheets("Sheetname").Protect _
Password:="mypassword", _
UserInterfaceOnly:=True, _
AllowFiltering:=True, _
AllowSorting:=True, _
AllowUsingPivotTables:=True
End Sub
Here is the ListSearch function from Luke. It returns the number of matches it has found.
Function ListSearch(text As String, wordlist As String, seperator As String, Optional caseSensitive As Boolean = False)
Dim intMatches As Integer
Dim res As Variant
Dim arrWords() As String
intMatches = 0
arrWords = Split(wordlist, seperator)
On Error Resume Next
Err.Clear
For Each word In arrWords
If caseSensitive = False Then
res = InStr(LCase(text), LCase(word))
Else
res = InStr(text, word)
End If
If res > 0 Then
intMatches = intMatches + 1
End If
Next word
ListSearch = intMatches
End Function
Finally, if you want to be able to remove the credentials, just assign this sub to a button.
Sub RemoveCredentials()
Dim ConnectionString As String
ConnectionString = GetConnectionString("None", "None")
UpdateQueryConnectionString ConnectionString
MsgBox "Credentials have been removed.", vbOKOnly, "Your Credentials"
End Sub
Hope this helps another person like me that was looking to solve this problem quickly.

Problems reading an Excel file in VB.net

I have been trying to upload and read an Excel file (.xls, or .xlsx)
I am upploading sucessfully using this code:
Protected Sub btnUpload_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles btnUpload.Click
Dim filepath As String = ""
If FileUpload1.HasFile Then
Try
Dim filename As String = FileUpload1.PostedFile.FileName
Dim extension = (filename.Substring(filename.LastIndexOf("."), (filename.Length() - filename.LastIndexOf("."))))
If extension = ".xlsx" Or extension = ".xls" Then
filepath = "\" & Common.toUnix(Now) & "_" & filename
FileUpload1.SaveAs(Server.MapPath("~/") & filepath)
' ==== NOW READ THE FILE
Else
StatusLabel.InnerText = "Only Excel file types are accepted (.xls/.xlsx)<br> File Uploaded had extension: " & extension
End If
Catch ex As Exception
StatusLabel.InnerText = "Upload status: The file could not be uploaded. The following error occured: " + ex.ToString()
End Try
End If
End Sub
It uploads OK, but when trying to read the file I get this error:
System.Data.OleDb.OleDbException (0x80004005): The Microsoft Jet database engine cannot open the file ''. It is already opened exclusively by another user, or you need permission to view its data.
I am using code to read similar to this:
vb.net traversing an xls / xlsx file?
Therefore the connection is as follows:
Dim connString As String = "Provider=Microsoft.Jet.OLEDB.4.0" & _
";Data Source=" & ExcelFile & _
";Extended Properties=Excel 8.0;"
Dim conn As OleDbConnection = Nothing
Dim dt As System.Data.DataTable = Nothing
Dim excelDataSet As New DataSet()
Try
conn = New OleDbConnection(connString)
conn.Open() '<<< ERROR IS RAISED ON THIS LINE
dt = conn.GetOleDbSchemaTable(OleDbSchemaGuid.Tables, Nothing)
If dt Is Nothing Then
Return Nothing
End If
Dim excelSheets(dt.Rows.Count) As String
Dim i As Integer = 0
For Each row As DataRow In dt.Rows
excelSheets(i) = row("payments").ToString
System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
If i = SheetNumber Then
Exit For
End If
Next
..................
I'm uploading to a shared server so don't have control as to permissions as such, but I do have read/write permissions and uploading Images works OK, but it's reading this file that I can't get to work.
NOTE
This error occurs with .xls files, when using .xlsx I get this error:
System.Data.OleDb.OleDbException (0x80004005): Cannot update. Database or object is read-only. at System.Data.OleDb.OleDbConnectionInternal
This error occurs on this line:
For Each row As DataRow In dt.Rows
So it appears it is uplpoading and opening the file OK, but not reading the rows....
I am not sure why that's happening either!
Any help would be much appreciated!
ACE is brutal, have troubles with it all the time and it cannot exist on a System in both 32 and 64 bit version at the same time. As a result I just dont use it at all.
To read an Excel XLSX file I use "EPPlus" which has proven to be very easy to deal with and extreamly efficient.
It ONLY works with XLSX (not XLS)
Example... (simple just pulls out first sheet as a datatable)
Public Function XlsxToDataTable(byteStream As IO.MemoryStream) As DataTable
Using pac As New OfficeOpenXml.ExcelPackage(byteStream)
Dim wb As OfficeOpenXml.ExcelWorkbook = pac.Workbook
Dim ws As OfficeOpenXml.ExcelWorksheet = wb.Worksheets(1) '1 based
Dim out As New DataTable
For iC As Integer = 1 To ws.Dimension.End.Column
out.Columns.Add(ws.Cells(1, iC).Value.ToString)
Next
For iR As Integer = 2 To ws.Dimension.End.Row
Dim nr As DataRow = out.NewRow
For iC As Integer = 1 To ws.Dimension.End.Column
nr(iC - 1) = ws.Cells(iR, iC).Value
Next
out.Rows.Add(nr)
Next
Return out
End Using
End Function

vb.net process start & stop

How can I create a process out of the below code so that I can tell when it starts & finishes?
Thanks in advance :)
Public Shared Function EmptyDirectory(ByVal mydir As String)
Try
'delete all directories
Dim myFolder As String
For Each myFolder In Directory.GetDirectories(mydir)
Directory.Delete(myFolder, True)
Next
'delete all files
Dim myFile As String
For Each myFile In Directory.GetFiles(mydir)
File.Delete(myFile)
Next
Catch Ex As Exception
'MsgBox(ex.Message)
End Try
Return False
End Function
FYI: This is what I thought would work:
Dim myProcess As System.Diagnostics.Process = New System.Diagnostics.Process()
myProcess.StartInfo.WindowStyle = System.Diagnostics.ProcessWindowStyle.Hidden
myProcess.Start(EmptyDirectory(DestDir))
Dim ClearDirectoryStartDateTime As String = DateTime.Now.ToString("d") & " " & DateTime.Now.ToString("HH:mm:ss")
StatusBoxName.Items.Add(ClearDirectoryStartDateTime & " - Cleaning")
' Wait until it ends.
myProcess.WaitForExit()
' Close the process to free resources.
myProcess.Close()
You might want to use threading. There's an interesting article on MSDN: http://msdn.microsoft.com/en-us/library/aa289178(v=vs.71).aspx