For several years we've been using code similar to the following (a result similar to that of net use) to convert UNC filenames to their legacy (drive letter) equivalents:
Dim network As Object: Set network = CreateObject("WScript.Network")
Dim netDrives As Object: Set netDrives = network.EnumNetworkDrives
Dim myLet As String
Dim myUnc As String
Dim i As Long
' loop through all network drives
For i = 0 To netDrives.count - 1 Step 2
myLet = netDrives.Item(i)
myUnc = netDrives.Item(i + 1)
myUnc = Replace(myUnc, "#SSL", "")
' hopefully we find it here
If InStr(LCase(uncname), LCase(myUnc)) Then
toLegacyName = myLet & Right(uncname, Len(uncname) - Len(myUnc))
Exit Function
End If
Next i
In the recent past, more login options (such as whether to use Citrix, VPN, or use the machine in the office) plus newer "file systems" (like Sharepoint) have rendered this code unreliable, where depending on how the user is signed on, network.EnumNetworkDrives may or may not return complete information. A drive may be present with Citrix but not using VPN, etc.
Are there other ways to do this? In the end, all we want to do is replicate net use.
Related
I am trying to place a QR code generated through an API (api.qrserver,com) in a Word table using VBA. For certain reasons, the option of simply using "DisplayBarcode" is not possible.
This is the call to the API:
sURL = "https://api.qrserver.com/v1/create-qr-code/?data=" & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+")) & "&size=240x240"
It seems to work well. I tried with a GET command and retrieved a string that - as I interpret - contains the QR code in png format.
Now, when I try to add the picture as a shape using
Set objGrafik = ActiveDocument.Shapes.AddPicture(sURL, True)
the call fails with runtime error 5152. As far as I could determine until now, the Addpicture method expects a pure filename and does not allow any of the following characters: /|?*<>:".
I also tried to store the GET result in an object variable:
Set oQRCode = http.responseText
but there I get the error "object required".
Research on the internet regarding a solution to either make the URL assignment work or to store the result as a picture didn't retrieve any useful results. Thanks in advance for your support
I am not sure that any of the ways you could insert something into Word (e.g. Shapes.AddPicture, InlineShapes.AddPicture, Range.InsertFile etc. will let you do that from any old https Url, although it seems to work for some Urls.
However, as it happens, you can use an INCLUDEPICTURE field to do it. FOr example
{ INCLUDEPICTURE https://api.qrserver.com/v1/create-qr-code/?data=Test&size=100x100 }
Here's some sample VBA to do that
Sub insertqrcode()
Dim sUrl As String
Dim f As Word.Field
Dim r1 As Word.Range
Dim r2 As Word.Range
' This is just a test - plug your own Url in.
sUrl = "https://api.qrserver.com/v1/create-qr-code/?data=abcdef&size=100x100"
' Pick an empty test cell in a table
Set r1 = ActiveDocument.Tables(1).Cell(5, 4).Range
' We have to remove the end of cell character to add the field to the range
' Simplify
Set r2 = r1.Duplicate
r2.Collapse WdCollapseDirection.wdCollapseStart
Set f = r2.Fields.Add(r2, WdFieldType.wdFieldIncludePicture, sUrl, False)
' If you don't want the field code any more, do this
f.Unlink
' check that we have a new inline shape that we could work with more
' if necessary
Debug.Print r1.InlineShapes.count
Set f = Nothing
Set r2 = Nothing
Set r1 = Nothing
End Sub
Using INCLUDEPICTURE works even on the current version of Mac Word (although I haven't tested that specific piece of VBA on Mac).
The only other way I have seen to do it uses WinHTTP to get the result from the web service, ADODB to stream it out to a local disk file, then AddPicture or whatever to include that file, so much more complicated and won't work on Mac either.
We currently output to our SharePoint 2016 site which can be done via a URL option.
With the advent of SP Online, this is no longer possible, so we are going to output the file to a Network Drive and use MS Flow to push into SP Online.
The Access Database has a lot of processes in it which gather data from various places, calculates and then provides this output at the end.
I am not up to speed on all things VBA, but I cannot find a solution to being able to help me with this.
The current script for this is below, which also deletes the previous file to allow for the new one.
How would I go about updating this to output the file to a Network Drive - \\ServerName\Team\Reports\SP_Movement\Files_To_SP
Private Sub Update_ShP() 'Refreshes report in SharePoint Reports folder
'Code to delete report file from ShP
DoCmd.SetWarnings False
Dim xmlhttp
Dim sharepointUrl, sharepointFileName
Dim aFile, bFile As String
Dim LobjXML As Object
' Parent Sharepoint URL
sharepointUrl = "https://dms.company.com/Reports/"
' Sets the report name we want to remove (BoM Data 1)
aFile = "Q_ATP_OUTPUT.xlsx"
Set LobjXML = CreateObject("Microsoft.XMLHTTP")
sharepointFileName = sharepointUrl & aFile
' Removes the data from the server, false means synchronous
LobjXML.Open "DELETE", sharepointFileName, False
' Sends the request to remove the file
LobjXML.send
Set LobjXML = Nothing
DoCmd.RunSavedImportExport "Export-Q_ATP_OUTPUT"
DoCmd.SetWarnings True
End Sub
Thanks
I am looking for a way to determine if a user current has multiple instances of an Access database open on their machine. The purpose of this check would be to ensure better session handling.
It is perfectly fine for a user to open multiple instances. There are some elements of our work where this is a necessity, to browse existing records while entering a new one.
I came across this old forum post where a function is given to output a list of the currently open databases in the Workspace. I thought I may be able to adapt this to determine if the same database is open more than once on their machine. However, in testing the function (removing the part that opens a separate database), it always outputs the name of our database twice, regardless of whether I have just one instance open, or two or three.
Here's the adapted code I am using:
Public Sub listDBs()
Dim wrkCurrentWorkSpace As Workspace
Dim i As Integer
Dim strDatabases As String
Set wrkCurrentWorkSpace = DBEngine.Workspaces(0)
For i = 0 To wrkCurrentWorkSpace.Databases.Count - 1
If (i = 0) Then
strDatabases = wrkCurrentWorkSpace.Databases(i).Name
Else
strDatabases = strDatabases & Chr$(13) & Chr$(10) & wrkCurrentWorkSpace.Databases(i).Name
End If
Next
MsgBox strDatabases
Set wrkCurrentWorkSpace = Nothing
End Sub
Am I doing something wrong here?
For better or worse we are launching an Access db from Sharepoint. Note that this db is not PUBLISHED to SP, people just double-click the link and open the db on their desktops.
So now we need to begin imposing the equivalent of some roles-based edit restrictions. I know there is a VBA CurrentWebUser function and a CurrentWebUserGroups which provides some basic data about who's accessing an Office file from Sharepoint. However my reading and limited experimenting with this stuff leads me to suspect that, for Access at least, these will only work with published dbs, and not ones that are just being launched and run locally, like we're doing.
Is there anything I can get from SP in a case like this? Web user and user group would be useful, so would whichever site/page the link is being clicked on. Is any of this available?
Thanks.
rabbit
Well, not in any simple way.
As you've already determined, Application.CurrentWebUser just returns Null.
However, there are several ways to query the user information from SharePoint.
The recommended way (also by me) if you're going to work with SharePoint extensively, is to use the CSOM api, which requires a .Net language, so you'll have to create a COM module, authenticate it separately, and that's all a lot of work.
However, if you're only using simple GET requests, you can also use the REST API and re-use the authentication MS Access uses itself (since MS Access uses MSXML2 to submit web requests to SharePoint, we can create our own MSXML2.XMLHTTP object and it will re-use the cookies Access uses).
The following code uses the JSONInterpreter object I've shared here on GitHub. You could convert it to use XML and MSXML if you don't want that dependency, though.
To execute a request, I use the following code, that assumes the Access application is authenticated, but if it isn't, it connects to the SharePoint site using ADO.
(For this code, MySiteName is a global variable containing the URL of your SharePoint site, without a trailing slash)
Public Function SPRestGetJSON(Site As String, Request As String) As String
Dim tries As Long
Dim Success As Boolean
Do
'Try to execute request
tries = tries + 1
Dim xmlHttpReq As Object 'MSXML2.XMLHTTP60
Set xmlHttpReq = CreateObject("Msxml2.XMLHTTP.6.0") 'New MSXML2.XMLHTTP60
xmlHttpReq.Open "GET", Site & Request, False
xmlHttpReq.setRequestHeader "Content-Type", "application/json"
xmlHttpReq.setRequestHeader "Accept", "application/json;odata=nometadata"
xmlHttpReq.send
Dim root As JSONInterpreter
Set root = New JSONInterpreter
root.JSON = xmlHttpReq.responseText
If Not root.Exists("odata.error") Then
Success = True
End If
If Not Success And tries = 1 Then
'Connect to SharePoint using WSS + ADO to create auth cookies inside MSXML
Dim conn As Object 'ADODB.Connection
Set conn = CreateObject("ADODB.Connection") 'New ADODB.Connection
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;WSS;DATABASE=" & Site
On Error Resume Next
conn.Execute "SELECT 1 From SomeTable" 'Execute to non-existent table but connect to sharepoint
On Error GoTo 0
conn.Close
End If
Loop While tries < 2 And Success = False
SPRestGetJSON = xmlHttpReq.responseText
End Function
Then, we can use that in a simple function:
Public Function GetSPUsername() As String
Dim jsi As New JSONInterpreter
jsi.JSON = SPRestGetJSON(MySiteName, "/_api/Web/CurrentUser")
GetSPUsername = jsi.item("LoginName").VBAVariant
End Function
Getting groups is also available. This code returns an array of dictionary objects, you can view the available keys in the locals window:
Public Function GetSPGroups() As Variant 'Array of dictionaries
Dim jsi As New JSONInterpreter
jsi.JSON = SPRestGetJSON(SiteName, "/_api/Web/CurrentUser/Groups")
GetSPGroups = jsi.item("value").VBAVariant
End Function
Then, to get the title of the first group the current user is a member of in the immediate window, we can use:
?GetSPGroups(0)!Title
We use VPN to connect to the work network. I have a mapped network drive that shows "Disconnected Network Drive" in My Computer immediately after I connect. While in this state I run a VBA routine:
Dim dr As String: dr = "F:\T\"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(dr) Then
Call fso.CreateFolder(dr)
End If
Even though the folder actually does exist, fso thinks it doesn't so it tries to create the folder and throws an error: Run-time error 76: Path not found. Of course it can't find it because it is in a disconnected state. Any other operations using that network drive will fail too.
So I open My Computer and manually double-click the network drive. It connects just fine and I no longer get the error when running the code again. But this is problematic. I need a solution in the code to automatically connect the network drive.
Possible solution 1: Just use the UNC path instead of mapped drive letter. The problem with that is that I don't know what the path is. Nor do I want to use UNC; the code needs to be flexible to work with wherever the drive maps to. It's policy from the brass.
Possible solution 2: Re-map the network drive using Net Use or WshNetwork. Again, this isn't really possible as I don't know what the UNC path is or will be.
Possible solution 3: Connect using ShellExecute While this would work, it isn't really palatable as it opens a window to explore the folder (could use SW_HIDE to avoid showing the window, but then how would I close it?). Furthermore it doesn't connect instantly. I would need a delay of uncertain length to make this work. Not a good answer. MSDN ShellExecute Function
So is there a better solution? How do I connect the drive while waiting for it to return and throwing an error if not able to connect?
I need it to work for both VBScript and VBA.
Slugster's suggestion to get the mapped UNC value is a good one. Here is my solution as adapted from this answer This works for VBScript and VBA.
Sub testget()
Debug.Print getUNC("F:\T\")
End Sub
Function getUNC(dir)
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim sDrive: sDrive = fso.GetDriveName(dir)
Set fso = Nothing
Dim sMap: sMap = GetMappedDrive(sDrive)
If sMap <> "" And sDrive <> sMap Then
getUNC = Replace(dir, sDrive, sMap)
Else
getUNC = dir
End If
End Function
Function GetMappedDrive(sDrive)
Dim wshNetwork: Set wshNetwork = CreateObject("WScript.Network")
Dim oDrives: Set oDrives = wshNetwork.EnumNetworkDrives
Dim i
For i = 0 To oDrives.Count - 1 Step 2
If UCase(oDrives.Item(i)) = UCase(sDrive) Then
GetMappedDrive = oDrives.Item(i + 1)
Exit For
End If
Next
Set oDrives = Nothing
Set wshNetwork = Nothing
End Function