Temporarily map a drive, copy a file, then remove the mapped drive (AC2007)

[AOB]

Hi guys,

Starting a new thread for an old question (original thread here) which I'm close to solving but have one last sticking point.

Original thread gives the background but basically I'm trying to download a file from a Sharepoint site via VBA. Had tried using FSO.CopyFile and the URLDownloadToFile API but neither were able to retrieve the file consistently - I found I had to keep manually putting the URL into Windows Explorer to make the connection to the Sharepoint directory first before the code would work.

Anyway - my workaround was to temporarily map the URL to a vacant drive letter on the local machine, then copy the file over, then drop the mapped drive again. A bit clunky but doesn't incorporate much of a delay and this download only has to happen once per day so a few seconds isn't going to kill anyone.

The good news is, the file download / copy now works every time (hurray! ) The bad news is that removing the temporarily mapped drive after the copy has taken place, doesn't (boooh! ) and I can't figure out why.

Here are the functions I use to map / unmap the drive :

Option Compare Database
Option Explicit
 
Private Const RESOURCETYPE_ANY = &H0&
Private Const CONNECT_UPDATE_PROFILE = &H1&
Private Const RESOURCE_CONNECTED As Long = &H1&
Private Const RESOURCE_GLOBALNET As Long = &H2&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
 
Private Type NETCONNECT
    dwScope As Long
    dwType As Long
    dwDisplayType As Long
    dwUsage As Long
    lpLocalName As String
    lpRemoteName As String
    lpComment As String
    lpProvider As String
End Type
 
Private Declare Function WNetAddConnection2 Lib "mpr.dll" _
  Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, _
    ByVal lpPassword As String, _
    ByVal lpUserName As String, _
    ByVal dwFlags As Long) As Long
 
Private Declare Function WNetCancelConnection2 Lib "mpr.dll" _
  Alias "WNetCancelConnection2A" (ByVal lpName As String, _
    ByVal dwFlags As Long, _
    ByVal fForce As Long) As Long
 
Public Function MapDrive(DriveLetter As String, DrivePath As String, Optional UserName As String, Optional Password As String) As Boolean
 
    Dim NetR As NETCONNECT
 
    With NetR
        .dwScope = RESOURCE_GLOBALNET
        .dwType = RESOURCETYPE_DISK
        .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
        .dwUsage = RESOURCEUSAGE_CONNECTABLE
        .lpLocalName = DriveLetter & ":"
        .lpRemoteName = DrivePath
    End With
 
    MapDrive = (WNetAddConnection2(NetR, UserName, Password, CONNECT_UPDATE_PROFILE) = 0)
 
End Function
 
Public Function UnMapDrive(DriveLetter As String) As Boolean
 
    Dim NetR As NETCONNECT
 
    With NetR
        .dwScope = RESOURCE_GLOBALNET
        .dwType = RESOURCETYPE_DISK
        .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
        .dwUsage = RESOURCEUSAGE_CONNECTABLE
        .lpLocalName = DriveLetter & ":"
        .lpRemoteName = ""
    End With
 
    ChDrive ("C")    ' Ensure that the drive letter to be dropped is not active
 
    UnMapDrive = (WNetCancelConnection2(DriveLetter, CONNECT_UPDATE_PROFILE, True) = 0)
 
End Function

I have separate functions to check existing drive mappings on the local machine and thus determine an appropriate vacant letter to use for the temporary mapping - they work fine.

Unfortunately the UnMapDrive function returns False (even though I switch the active drive to C: and force the connection to be cancelled with the fForce flag) So the mapping always remains on the users profile.

Any ideas how I can get around this? I don't want to permanently map drives on the users' profiles, just briefly for the purposes of this daily file download.

Thanks

Al

 

[vbaInet]

Al, unfortunately I don't have time to re-test any of this or look through your entire code, but I know that the easiest way to implement this (instead of APIs) would be through Windows Script Host (i.e. WScript). Look into this.

Quick search yields:
http://ss64.com/vb/driverm.html

 

[AOB]

vbaInet

Your knowledge knows no bounds - this works perfectly, and also avoids the use of API's which I'm always slightly wary of. Two birds, one stone.

Thank you as ever, this a far more elegant way of doing this

Have a great weekend!

Al

 

[vbaInet]

Thank you as ever, this a far more elegant way of doing this

Very much so!

Perhaps you can post your solution for those who might come across your thread.

Have a good weekend too.

 

[AOB]

With pleasure...

Here are some of the functions I've written relating to drive mapping (have removed all the error handling for succinctness)

Option Compare Database
Option Explicit
 
Private objNetwork As Object
 
' ---------------------------------------------
 
Public Function GetMappedDrives() As Variant
 
  ' Returns a 2-D array of (1) drive letters and (2) corresponding network paths of all mapped drives on the users machine
 
  Dim colDrives As Variant
  Dim arrMappedDrives() As Variant
  Dim i As Variant
 
  Set objNetwork = CreateObject("WScript.Network")
  Set colDrives = objNetwork.EnumNetworkDrives
 
  ReDim arrMappedDrives(1 To 2, 1 To 1)
 
  For i = 0 To colDrives.Count - 1 Step 2
 
    If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
 
      ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
 
    End If
 
    arrMappedDrives(1, UBound(arrMappedDrives, 2)) = colDrives.Item(i)
    arrMappedDrives(2, UBound(arrMappedDrives, 2)) = colDrives.Item(i + 1)
 
  Next i
 
  GetMappedDrives = arrMappedDrives
 
  Set colDrives = Nothing
  Set objNetwork = Nothing
 
End Function
 
' ---------------------------------------------
 
Public Function IsAlreadyMapped(strPath As String) As String
 
  ' Tests if a given network path is already mapped on the users machine
  ' (Returns corresponding drive letter or ZLS if not found)
 
  Dim strMappedDrives() As Variant
  Dim i As Long
 
  strMappedDrives = GetMappedDrives
 
  For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
 
    If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
 
      IsAlreadyMapped = strMappedDrives(1, i)
      Exit For
 
    End If
 
  Next i
 
  Set objNetwork = Nothing
 
End Function
 
' ---------------------------------------------
 
Public Function AvailableDriveLetter() As String
 
  ' Returns the last available (unmapped) drive letter, working backwards from Z:
 
  Dim strMappedDrives() As Variant
  Dim i As Long
  Dim j As Long
 
  strMappedDrives = GetMappedDrives
 
  For i = Asc("Z") To Asc("A") Step -1
 
    For j = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
 
      If UCase(Left(strMappedDrives(1, j), 1)) Like Chr(i) Then GoTo NextLetter
 
    Next j
 
    AvailableDriveLetter = Chr(i)
    Exit For
 
NextLetter:
 
  Next i
 
  Set objNetwork = Nothing
 
End Function
 
' ---------------------------------------------
 
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
 
  If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
 
  Set objNetwork = CreateObject("WScript.Network")
 
  objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
 
  MapDrive = True
 
  Set objNetwork = Nothing
 
End Function
 
' ---------------------------------------------
 
Public Function UnMapDrive(strDriveLetter As String) As Boolean
 
  Set objNetwork = CreateObject("WScript.Network")
 
  objNetwork.RemoveNetworkDrive strDriveLetter & ":", True, True
 
  UnMapDrive = True
 
  Set objNetwork = Nothing
 
End Function

Then I can just run the following :

Private Function DownloadFile(strPath As String) As String
 
  Dim objFSO As Object
  Dim strMappedDriveLetter As String
  Dim strFileLocal As String
 
  Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  With objFSO
 
    strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
 
    If Not Len(strMappedDriveLetter) > 0 Then
 
      strMappedDriveLetter = AvailableDriveLetter
 
      If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
 
        MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
        Exit Function
 
      End If
 
    End IF
 
    strFileLocal = "<Path to where you want the local copy to be saved>"
 
    If .FileExists(strPath) Then .CopyFile strPath, strFileLocal, True
 
    If Not UnMapDrive(strMappedDriveLetter) Then
 
      MsgBox "Failed to unmap SharePoint directory", vbExclamation, "Drive Unmapping Failure"
 
    End If
 
    If Not .FileExists(strFileLocal) Then
 
      MsgBox "File could not be copied", vbExclamation, "File Copy Failure"
      Exit Function
 
    End If
 
  End With
 
  Set objFSO = Nothing
  DownloadFile=strFileLocal
 
End Function

 

[vbaInet]

May I offer some advice? There's a bit of re-invention going on here so what I'm about to say will cause you to rethink 3 of your functions

* EnumNetworkDrives is an enumeration of networked drives, not fixed drives like C or D, so you may end up trying to use C or D (which you really don't want to do).
* Instead of all of that use the FileSystemObject of WScript (or Scripting Runtime Library) to find free drives. There are only 26 drives to use, i.e. A to Z:

1. Create an array with 26 values, A to Z (or 24 values - minus "C" and "D" since they're commonly used)
2. Loop through the array and for each item check:
a. objFSO.DriveExists(array(x)) - this will check whether a file is in use or not
b. If you want to check the path of a drive use the ShareName property of a Drive object. This will return a network path if it's mapped.

 

[vbaInet]

Here you go. varDrive returns a free drive:

    Dim objFso       As Object
    Dim varDrives    As Variant
    Dim varDrive     As Variant
    
    Set objFso = CreateObject("Scripting.FileSystemObject")
    
    varDrives = Array("A", "B", "C", "D", "E", "F", "G", _
                      "H", "I", "J", "K", "L", "M", "N", _
                      "O", "P", "Q", "R", "S", "T", "U", _
                      "V", "W", "X", "Y", "Z")
    
    For Each varDrive In varDrives
        If Not objFso.DriveExists(varDrive) Then
            Exit For
        End If
    Next
    
    Debug.Print [COLOR="Blue"]varDrive[/COLOR]

 

[vbaInet]

Forgot to mention one last thing:

If UCase(Left(strMappedDrives(1, j), 1)) Like Chr(i) Then [COLOR="Blue"]GoTo NextLetter[/COLOR]

... it's best to avoid this type of structure. Best thing is to use an IF..ELSE block instead if you can.

 

[AOB]

Thanks vbaInet this is all extremely useful

Okay here are two of the three functions updated

Public Function GetMappedDrives() As Variant
 
[COLOR=green]' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine[/COLOR]
 
  Dim objFSO As Object
  Dim objDrive As Object
  Dim arrMappedDrives() As Variant
  Dim i As Long
 
  Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  ReDim arrMappedDrives(1 To 2, 1 To 1)
 
  For i = Asc("A") To Asc("Z")
 
    If objFSO.DriveExists(Chr(i)) Then
 
      Set objDrive = objFSO.GetDrive(Chr(i))
 
      If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
 
        ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
 
      End If
 
      arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i)            [COLOR=green]' Could also use objDrive.DriveLetter...[/COLOR]
      arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
 
    End If
 
  Next i
 
  GetMappedDrives = arrMappedDrives
 
  Set objDrive = Nothing
  Set objFSO = Nothing
 
End Function

Public Function AvailableDriveLetter() As String
 
[COLOR=green]' Returns the last available (unmapped) drive letter, working backwards from Z:[/COLOR]
 
  Dim objFSO As Object
  Dim i As Long
 
  Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  For i = Asc("Z") To Asc("A") Step -1
 
    Select Case objFSO.DriveExists(Chr(i))
 
      Case True
 
      Case False
 
        Select Case Chr(i)
 
          Case "C", "D"     [COLOR=green]' Not actually necessary - .DriveExists should return True anyway...[/COLOR]
 
          Case Else
 
            AvailableDriveLetter = Chr(i)
            Exit For
 
        End Select
 
    End Select
 
  Next i
 
  Set objFSO = Nothing
 
End Function

I tried changing the IsAlreadyMapped function along the same lines but when I tested it I found that if I performed a .DriveExists on the UNC path to be checked, it returns False, even though I can see the path mapped in WE. So not entirely sure how to use FSO to check if a UNC is already mapped and return the letter (as opposed to the other way around, i.e. check if a letter is already mapped and return the path)

 

[vbaInet]

So basically this is what you're trying to do:
1. Check if it has already been mapped
2. If it has go to step 5, otherwise go to step 3
3. Check for a free drive
4. Map the drive, return the path
5. Download the file, disconnect the mapped drive (if it wasn't mapped originally)
?

Here's some code. Break it down as you see fit:

Public Function GetSharePath() As String
    Dim objFso          As Object
    Dim objDrives       As Object
    Dim objDrive        As Object
    Dim objDicDrives    As Object
    Dim varDrives       As Variant
    Dim varDrive        As Variant
    Dim x               As Integer
    Const [COLOR="blue"]STR_SHARENAME [/COLOR]As String = "[COLOR="Blue"]\\UNC\Path[/COLOR]"
    
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objDrives = objFso.Drives
    
    ' Save drive letters into dictionary
    Set objDicDrives = CreateObject("Scripting.Dictionary")
    For x = 65 To 90
        objDicDrives.Add Chr(x), vbNullString
    Next
    
    ' Check if already mapped, return path and exit function
    For Each objDrive In objDrives
        With objDrive
            If [COLOR="blue"]STR_SHARENAME [/COLOR]= .ShareName Then
                GetSharePath = .Path
                Exit Function
            End If
            objDicDrives.Remove .DriveLetter
        End With
    Next
    
    ' Hasn't been mapped so get free drive letter
    For Each varDrive In objDicDrives.Keys
        If Not objFso.DriveExists(varDrive) Then
            Exit For
        End If
    Next
    
    ' Map drive and return path. varDrive will contain the free drive letter
    ' ----- your code to do the above goes here ----
    GetSharePath = "your return value"
    
    ' Clean up
    Set objFso = Nothing
    Set objDrive = Nothing
    Set objDrives = Nothing
    Set objDicDrives = Nothing
End Function

You'll obviously need to cater for the disconnection part. You obviously don't want to delete a mapped drive that already existed.

NB: DriveExists is used for drive letters.

 

[AOB]

Super - thanks vbaInet. Learning a lot about FSO, I've never delved into the Drives functions before. So much neater than using the WScript.Network object.

My existing code basically does the same thing (albeit split into several smaller functions which can feed parameters to each other - I like to do it this way so the module can be ported around to other potential DB's and save me writing bespoke code each time)

So I loop through the existing drives and compare the paths with the defined string until I get a hit (or not) I just thought there might be a quicker way of doing it (the .DriveExists method in MSDN suggests either a drive letter or path can be used but evidently not, based on your comment above and my own experimentation)

DriveExists Method

Returns True if the specified drive exists; False if it does not.

object.DriveExists(drivespec)

Arguments

object Required. Always the name of a FileSystemObject.

drivespec Required. A drive letter or a complete path specification.

 

[vbaInet]

My existing code basically does the same thing

Similar, there are subtle differences (in tactic and performance)
By the way, if you want to return two or more values from a function, use a Type instead of an array.

... (albeit split into several smaller functions which can feed parameters to each other - I like to do it this way so the module can be ported around to other potential DB's and save me writing bespoke code each time)

Yes modularity is very important that was why I said in my last post that you should break it up as you see fit.

As for DriveExists, you would expect it to work with UNC paths but it doesn't seem to. I think it refers to local paths (C:\).