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")
Related
I am working in Access 2013 and try to get GetRawInputDeviceList, GetRawInputDeviceInfo, RegisterRawInputDevices and GetRawInputData equivalents for VBA with no success. I have also searched in vain for a procedure, function or module to get a list of connected HID devices to a computer to pick out a barcode scanner. This is the beginning of the third week so I am on my knees begging for assistance. Do any of you all have a module you're willing to share, a link to a website where this is dealt with? Any help is greatly appreciated.
Using the GetRawInputDeviceList API from VBA would be pretty tricky because of the pRawInputDeviceList parameter. Unless you're willing to jump through a ton of hoops to manage your own memory and manually handle the resulting array of RAWINPUTDEVICELIST in raw memory, you'll be better off coming at this from another direction.
Most barcode scanners I've dealt with present themselves to Windows as a keyboard. One possible solution would be to use a WMI query to enumerate attached Win32_Keyboard devices:
Private Sub ShowKeyboardInfo()
Dim WmiServer As Object
Dim ResultSet As Object
Dim Keyboard As Object
Dim Query As String
Query = "SELECT * From Win32_Keyboard"
Set WmiServer = GetObject("winmgmts:root/CIMV2")
Set ResultSet = WmiServer.ExecQuery(Query)
For Each Keyboard In ResultSet
Debug.Print Keyboard.Name & vbTab & _
Keyboard.Description & vbTab & _
Keyboard.DeviceID & vbTab & _
Keyboard.Status
Next Keyboard
End Sub
Note: If it doesn't turn up there, you can enumerate all of the USB devices by querying CIM_USBDevice: Query = "SELECT * From Win32_Keyboard"
EDIT: Per the comments, the above code won't return the handle needed to register to receive raw input events. This should get you started though - the RegisterRawInputDevices and GetRawInputData aspects are beyond the scope of what will easily go in an answer. Take a hack at it, and if you run into any problems post your code in another question.
Declarations:
Private Type RawInputDeviceList
hDevice As Long
dwType As Long
End Type
Private Type RidKeyboardInfo
cbSize As Long
dwType As Long
dwKeyboardMode As Long
dwNumberOfFunctionKeys As Long
dwNumberOfIndicators As Long
dwNumberOfKeysTotal As Long
End Type
Private Enum DeviceType
TypeMouse = 0
TypeKeyboard = 1
TypeHID = 2
End Enum
Private Enum DeviceCommand
DeviceName = &H20000007
DeviceInfo = &H2000000B
PreParseData = &H20000005
End Enum
Private Declare Function GetRawInputDeviceList Lib "user32" ( _
ByVal pRawInputDeviceList As Long, _
ByRef puiNumDevices As Long, _
ByVal cbSize As Long) As Long
Private Declare Function GetRawInputDeviceInfo Lib "user32" Alias "GetRawInputDeviceInfoW" ( _
ByVal hDevice As Long, _
ByVal uiCommand As Long, _
ByVal pData As Long, _
ByRef pcbSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Sample of retrieving device names with GetRawInputDeviceInfo:
Private Sub SampleCode()
Dim devices() As RawInputDeviceList
devices = GetRawInputDevices
Dim i As Long
For i = 0 To UBound(devices)
'Inspect the type - only looking for a keyboard.
If devices(i).dwType = TypeKeyboard Then
Dim buffer As String
Dim size As Long
'First call with a null pointer returns the string length in size.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, 0&, size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
'Size the string buffer.
buffer = String(size, Chr$(0))
'The second call copies the name into the passed buffer.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, StrPtr(buffer), size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
Debug.Print buffer
End If
End If
End If
Next i
End Sub
Private Function GetRawInputDevices() As RawInputDeviceList()
Dim devs As Long
Dim output() As RawInputDeviceList
'First call with a null pointer returns the number of devices in devs
If GetRawInputDeviceList(0&, devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
'Size the output array.
ReDim output(devs - 1)
'Second call actually fills the array.
If GetRawInputDeviceList(VarPtr(output(0)), devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
GetRawInputDevices = output
End If
End If
End Function
Sorry about the side scrolling.
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
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
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).
Is there a way to get the name of the computer in VBA?
Dim sHostName As String
' Get Host Name / Get Computer Name
sHostName = Environ$("computername")
You can do like this:
Sub Get_Environmental_Variable()
Dim sHostName As String
Dim sUserName As String
' Get Host Name / Get Computer Name
sHostName = Environ$("computername")
' Get Current User Name
sUserName = Environ$("username")
End Sub
Looks like I'm late to the game, but this is a common question...
This is probably the code you want.
Please note that this code is in the public domain, from Usenet, MSDN, and the Excellerando blog.
Public Function ComputerName() As String
'' Returns the host name
'' Uses late-binding: bad for performance and stability, useful for
'' code portability. The correct declaration is:
' Dim objNetwork As IWshRuntimeLibrary.WshNetwork
' Set objNetwork = New IWshRuntimeLibrary.WshNetwork
Dim objNetwork As Object
Set objNetwork = CreateObject("WScript.Network")
ComputerName = objNetwork.ComputerName
Set objNetwork = Nothing
End Function
You'll probably need this, too:
Public Function UserName(Optional WithDomain As Boolean = False) As String
'' Returns the user's network name
'' Uses late-binding: bad for performance and stability, useful for
'' code portability. The correct declaration is:
' Dim objNetwork As IWshRuntimeLibrary.WshNetwork
' Set objNetwork = New IWshRuntimeLibrary.WshNetwork
Dim objNetwork As Object
Set objNetwork = CreateObject("WScript.Network")
If WithDomain Then
UserName = objNetwork.UserDomain & "\" & objNetwork.UserName
Else
UserName = objNetwork.UserName
End If
Set objNetwork = Nothing
End Function
A shell method to read the environmental variable for this courtesy of devhut
Debug.Print CreateObject("WScript.Shell").ExpandEnvironmentStrings("%COMPUTERNAME%")
Same source gives an API method:
Option Explicit
#If VBA7 And Win64 Then
'x64 Declarations
Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#Else
'x32 Declaration
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#End If
Public Sub test()
Debug.Print ComputerName
End Sub
Public Function ComputerName() As String
Dim sBuff As String * 255
Dim lBuffLen As Long
Dim lResult As Long
lBuffLen = 255
lResult = GetComputerName(sBuff, lBuffLen)
If lBuffLen > 0 Then
ComputerName = Left(sBuff, lBuffLen)
End If
End Function