Network file path not opening in VBA/MSAccess - vba

I'm using VBA in MS Access, and one of the subs takes a file path in a network, checks if the file exists or not, and write the result of a query on it.
The problem is that when I try to run the code, it gives me error 52 (Bad file name or number). But if I open the network path in windows explorer first, for example, after that the error doesn't happen anymore. Any ideas on what the problem might be?
Here is some of the code I'm running:
fpath = "\\networkpath\file.txt"
DeleteFile fpath
Sub DeleteFile(ByVal FileToDelete As String)
FileExists(FileToDelete) Then
SetAttr FileToDelete, vbNormal
FileToDelete
End If
End Sub
Function FileExists(ByVal FileToTest As String) As Boolean
FileExists = (Dir(FileToTest) <> "") 'this is where the error happens
End Function

Does the UNC path you use contain any non-Ascii characters, like accents? What is the exact path?
None of the file functions in VBA work well with Unicode anyway.
You could try to use the FileSystemObject to achieve the same a bit more reliably than the build-in VBA functions:
Public Function FileExists(filePath as string) as Boolean
Dim o As Object
Set o = CreateObject("Scripting.FileSystemObject")
FileExists = o.FileExists(filePath)
End Function
An alternative using the Win32 API tha works in 32 and 64 bit environments:
Private Const INVALID_FILE_ATTRIBUTES As Long = -1
#If VBA7 Then ' Win API Declarations for 32 and 64 bit versions of Office 2010 and later
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As LongPtr) As Long
#Else ' WIN API Declarations for Office 2007
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
#End If
Public Function FileExists(fname As Variant) As Boolean
If IsNull(fname) Or IsEmpty(fname) Then Exit Function
' Make sure that we can take care of paths longer than 260 characters
If Left$(fname, 2) = "\\" Then
FileExists = GetFileAttributes(StrPtr("\\?\UNC" & Mid$(fname, 2))) <> INVALID_FILE_ATTRIBUTES
Else
FileExists = GetFileAttributes(StrPtr("\\?\" & fname)) <> INVALID_FILE_ATTRIBUTES
End If
End Function

Related

Run Time error 5

Function GetUNC(strMappedDrive As String) As String
Dim objFso As FileSystemObject
Set objFso = New FileSystemObject
Dim strDrive As String
Dim strShare As String
'Separated the mapped letter from
'any following sub-folders
strDrive = objFso.GetDriveName(strMappedDrive)
'find the UNC share name from the mapped letter
strShare = objFso.Drives(strDrive).ShareName '<<<< this is the line that the code fails on
'The Replace function allows for sub-folders
'of the mapped drive
GetUNC = Replace(strMappedDrive, strDrive, strShare)
Set objFso = Nothing 'Destroy the object
End Function
It works fine on my laptop and network, but when a colleague uses the same spreadsheet with the same code on their laptop and network the code throws a run-time error 5 exception 'invalid procedure call or argument' at the following line:
strShare = objFso.Drives(strDrive).ShareName
When I hover over the line of code I see: when I run the code to this point I see a file path.
My colleague has tried running the code on his local drive as well as a network drive with no success. We both have the same references selected as well. Does anyone know what I need to do to get this working on my colleagues machine?
Not entirely sure what the issue is, but it might be worth using an API call instead:
#If Win64 Then
Declare PtrSafe Function WNetGetConnection32 Lib "MPR.DLL" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
#Else
Declare Function WNetGetConnection32 Lib "MPR.DLL" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
#End If
Dim lpszRemoteName As String * lBUFFER_SIZE
Dim lSize As Long
Const NO_ERROR As Long = 0&
Const lBUFFER_SIZE As Long = 255&
Function GetUNC(ByRef strDriveLetter As String) As String
strDriveLetter = UCase$(strDriveLetter) & ":"
GetUNC = IIf(WNetGetConnection32(strDriveLetter, lpszRemoteName, lBUFFER_SIZE) = NO_ERROR, lpszRemoteName, "Error")
End Function
Then simply use something like:
MsgBox GetUNC("S")

how to use shell32.dll ExtractAssociatedIcon across UNC path in VB.net

I have found plenty of examples in C#, but I cannot make this work in VB no matter what I try. The only icon I can extract is the one representing a file with no association. If there is a better approach I am open to that too. Here is the code:
Declaration:
Declare Auto Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As IntPtr, ByVal lpIconPat As String, ByRef lpiIcon As Integer) As IntPtr
Other Code:
Dim handle As IntPtr
Dim li As ListViewItem
Dim modul As System.Reflection.Module()
For Each filename As FileInfo In quotesFolder.GetFiles()
If ImgLstQuotes.Images.ContainsKey(filename.Extension) Then
Else
modul = System.Reflection.Assembly.GetExecutingAssembly.GetModules()
'handle = ExtractAssociatedIcon(Marshal.GetHINSTANCE(modul(0)), filename.FullName, -1) 'doesnt work
'handle = ExtractAssociatedIcon(IntPtr.Zero(), filename.FullName, -1) 'doesn't work
handle = ExtractAssociatedIcon(Process.GetCurrentProcess().Handle, filename.FullName, -1) 'doesn't work
ImgLstQuotes.Images.Add(filename.Extension, Drawing.Icon.FromHandle(handle))
End If
li = LstVwQuotes.Items.Add(filename.Name, filename.Extension)
li.Name = UCase(filename.Name)
li.SubItems.Add(filename.LastWriteTime)
Next
Thanks in advance!

VBA: Opening a text file from URL to read

I have a text file on my website that contains only the string "1.15" (for the version of the application I am writing). Upon initialization of the user form, I would like to read that file from its URL and have the string "1.15" returned so that I can check it against the application's version (stored as a const string).
Here is the format I'd like to have...
Const version As String = "1.14"
Const currentVersionURL As String = "http://mywebsite.com/currentversion.txt"
Sub UserForm_Initialize()
If version <> GetCurrentVersionNumber() Then
MsgBox "Please update the application."
End If
End Sub
Function GetCurrentVersionNumber() As String
' What do I put here? :(
End Function
I am aware of the Workbooks.OpenText method, but I don't want to write the string into a workbook. I have tried using the ADODB.LoadFromFile and WinHttp.WinHttpRequest.Open methods, but both are unable to read the file.
Any suggestions for what to fill GetCurrentVersionNumber() with would be greatly appreciated. :)
While it doesn't directly answer your question, a simpler approach would be to make it an XML file instead of a text file. There are more built-in tools to easily open an XML file from a URL. The secondary advantage is that it also makes it more flexible, so you can more easily add new data elements to the XML file later on.
For instance, if you made a http://mywebsite.com/currentversion.xml file that looked like this:
<?xml version="1.0" encoding="utf-8" ?>
<AppData>
<Version>1.14</Version>
</AppData>
Then, in VB.NET you could easily read it like this:
Function GetCurrentVersionNumber() As String
Dim doc As New XmlDocument()
doc.Load("http://mywebsite.com/currentversion.xml")
Return doc.SelectSingleNode("/AppData/Version").InnerText
End Function
Or, in VBA, you could read it like this:
Function GetCurrentVersionNumber() As String
Dim doc As MSXML2.DOMDocument?? ' Where ?? is the version number, such as 30 or 60
Set doc = New MSXML2.DOMDocument??
doc.async = False
doc.Load("http://mywebsite.com/currentversion.xml")
GetCurrentVersionNumber = doc.SelectSingleNode("/AppData/Version").Text
End Function
You will need to add a reference to the Microsoft XML, v?.? library, though.
Try this (UNTESTED)
Option Explicit
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
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Const currentVersionURL As String = "http://mywebsite.com/currentversion.txt"
Const version As String = "1.14"
Dim Ret As Long
Sub UserForm_Initialize()
If version <> GetCurrentVersionNumber() Then
MsgBox "Please update the application."
End If
End Sub
Function GetCurrentVersionNumber() As String
Dim strPath As String
'~~> Destination for the file
strPath = TempPath & "currentversion.txt"
'~~> Download the file
Ret = URLDownloadToFile(0, currentVersionURL, strPath, 0, 0)
'~~> If downloaded
If Ret = 0 Then
Dim MyData As String, strData() As String
Open "C:\MyFile.Txt" For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
GetCurrentVersionNumber = MyData
Else
MsgBox "Unable to download the file"
GetCurrentVersionNumber = ""
End If
End Function
'~~> Get Users Temp Path
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function

Excel 64-bit and comdlg32.dll custom colours

I'm trying to adapt the code in either here or here to open the custom colour palette in Excel 2010 64-bit but cannot get it to work. Code on both sites work fine in Excel 2003
One attempt
Option Explicit
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Dim CustomColors() As Byte
Private Sub Command1_Click()
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As Long
Dim lReturn As Long
cc.lStructSize = Len(cc)
cc.hwndOwner = Application.Hwnd
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
Application.Caption = "RGB Value User Chose: " & Str$(cc.rgbResult)
Application.BackColor = cc.rgbResult ' Visual Basic only ****
Application.Section(0).BackColor = cc.rgbResult ' Access only **********
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
MsgBox "User chose the Cancel Button"
End If
End Sub
Private Sub Form_Load()
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
Dim i As Integer
For i = LBound(CustomColors) To UBound(CustomColors)
CustomColors(i) = 0
Next i
End Sub
This runs ok but doesn't show the dialog. I've also tried changing some LONG types to LONGPTR with no success. Does anyone know how to get this working on a 64-bit machine; or if it's even possible? Perhaps there's a new library?
Thanks
Edit: Slight rewording with offer of bounty...
How do I access and use this custom colour chooser (image below) in Excel 2010 64-bit (MUST work on 64-bit!) to set cells in Excel 2010 with the colour chosen and store the colour? The image is taken from Excel 2010 64-bit by selecting fill button>more colors>Custom
Valid XHTML http://img851.imageshack.us/img851/2057/unlednvn.png
Two things I would try. First, replace every use of Long with LongPtr.
Private Type CHOOSECOLOR
lStructSize As LongPtr
hwndOwner As LongPtr
hInstance As LongPtr
rgbResult As LongPtr
lpCustColors As String
flags As LongPtr
lCustData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As LongPtr
Second, replace the use of Len with LenB.
Private Sub Command1_Click()
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As LongPtr
Dim lReturn As LongPtr
cc.lStructSize = LenB(cc)
cc.hwndOwner = Application.Hwnd
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
Application.Caption = "RGB Value User Chose: " & Str$(cc.rgbResult)
Application.BackColor = cc.rgbResult ' Visual Basic only ****
Application.Section(0).BackColor = cc.rgbResult ' Access only **********
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
MsgBox "User chose the Cancel Button"
End If
End Sub
Private Sub Form_Load()
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
Dim i As Integer
For i = LBound(CustomColors) To UBound(CustomColors)
CustomColors(i) = 0
Next i
End Sub
More Info
LongPtr Data Type
LenB Function
AFAIK 32-bit dll's cannot be used by a 64-bit application.
Use comdlg64.dll instead (if there is such a dll).
Using google reveals that there a host of viruses floating around on the net by that name.
So if comdlg64.dll is not on your machine don't download it from the net!
(Unless you want to experience zombieness).

How to register a type library in VBA

I am trying to register a type library programatically from VBA code, using two variants of a technique found using Google (Subs RegisterTypeLibrary and RegisterTypeLibrary2 below).
The code below crashes with an access violation on the call to LoadTypeLib / LoadTypeLibEx. What am I doing wrong? In case it's relevant, the type library is a TLB file generated from a .NET assembly using tlbexp.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As Object) As Long
Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
pFileName As Byte, pptlib As Object) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
ByVal ptlib As Object, szFullPath As Byte, _
szHelpFile As Byte) As Long
Private Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLib(abNullTerminatedFileName(0), objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLib", "Error registering type library " & FileName
End If
lHResult = RegisterTypeLib(objTypeLib, abNullTerminatedFileName(0), 0)
If lHResult <> 0 Then
Err.Raise lHResult, "RegisterTypeLib", "Error registering type library " & FileName
End If
Exit Sub
End Sub
Private Sub RegisterTypeLibrary2(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
EDIT
I suspect it is something specific about my type library. I've found a solution which I've posted as an answer below.
I've found a solution, using the code below. Basically, the third parameter to LoadTypeLibEx (ITypeLib** in C/C++) is declared as stdole.IUnknown instead of as Object.
To do so, I needed to add a reference to stdole32.tlb to the VBA project.
I suspect there is something about my type library that means it can't be declared as a VB (late-bound) Object.
I could also have declared the third parameter as Long, but I'm not sure that wouldn't lead to problems with reference counting.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As stdole.IUnknown) As Long
Public Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As stdole.IUnknown
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
I suspect your type library (TLB) has errors because the code you provided works when I tested against a third-party TLB.
I am assuming you are going to use your .NET Assembly from VBA. Therefore, I suggest you make sure you can reference your TLB from VBA without errors.
Note, that all objects exposed by your .NET library must have public constructors that accept no arguments. This may be causing the problem.