ChDrive and ChPath to a network drive

[ker_01]

Using 2003, although this workbook might also be used in 2007.

I adapted the code below to help me autoload sheets from other source
workbooks so that I can get all my raw data in one workbook without having to
manually copy/paste sheets.

In my initial testing of the following code, I used a local drive/path
(different folders on my desktop) and everything worked as expected.

However, now that I'm testing against the real path (LAN location), I'm
getting an error on ChDrive. I'm thinking that maybe ChDrive only works on
mapped drive letters? Since this workbook needs to work for multiple users
who will have the network drive mapped to different drive letters, I need to
use the raw path. Any suggestions?

Sub TestTheRawDataFunction
'sub works with a local drive path, but not with this network path
zz = PullAllRawData(Sheet1, Sheet15, _
"\\wabr833\Pemgt\Scorecard\Operations\RawData1", , _
"Select the current scorecard source file")
End Sub

Function PullAllRawData(SourceSheet As Worksheet, _
DestSheet As Worksheet, _
Optional PathOnly As String, _
Optional MyFullFilePath As String, _
Optional TitleString As String)

Dim SaveDriveDir As String

'save default path
SaveDriveDir = CurDir

If Len(TitleString) = 0 Then TitleString = "Please select the appropriate
file"

If Len(MyFullFilePath) > 0 Then
'do nothing
ElseIf Len(PathOnly) > 0 Then
'change to new path
ChDrive PathOnly '<< errors here, "invalid procedure call or argument"
ChDir PathOnly
'get the file
NewFN = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),
*.xls;*.xlsx;*.xlsm;*.csv", Title:=TitleString)
If NewFN = False Then
' They pressed Cancel
MsgBox "Stopping because you did not select a file"
'return to original default path
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Function
Else
MyFullFilePath = NewFN
End If

'change back to default path
Else
'start from scratch

End If

Dim I As Integer
Dim owb As Workbook 'original/main
Dim twb As Workbook 'temp/data file
Dim ows As Worksheet
Dim tws As Worksheet

DestSheet.Activate
Set owb = ActiveWorkbook
Set ows = ActiveWorkbook.ActiveSheet
'clear the destination sheet to make sure there isn't leftover old data
ows.Cells.Clear

Application.StatusBar = "Opening File " & MyFullFilePath

'Open source workbook
Application.DisplayAlerts = False
Set twb = Workbooks.Open(Filename:=MyFullFilePath, UpdateLinks:=0,
ReadOnly:=True)
Application.DisplayAlerts = True
twb.Activate
twb.Sheets(1).Activate
'grab the data
twb.Sheets(1).Cells.Select
Selection.Copy
ows.Activate
ows.Range("A1").Select
ActiveSheet.Paste
ows.Range("A1").Select
ActiveSheet.PasteSpecial (xlPasteValuesAndNumberFormats)

'Select/copy a single cell to avoid clipboard warnings
ActiveSheet.Range("A1").Copy

'close the workbook to get it out of the way
Application.DisplayAlerts = False 'just in case the clipboard trick doesn't
work
twb.Close SaveChanges:=False
Application.DisplayAlerts = True

Application.StatusBar = False

'return to original default path
ChDrive SaveDriveDir
ChDir SaveDriveDir

End Function

 

[Dave Peterson]

Yep. ChDrive and ChDir are limited to those mapped drives.

But Windows supplies an API that'll work for UNC paths as well as mapped
drives. So you could use something like this instead:

(Saved from an old post)

Option Explicit
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path."
End Sub
Sub Loader1()

Dim myFileName As Variant
Dim myCurFolder As String
Dim myNewFolder As String

myCurFolder = CurDir
myNewFolder = "\\share\folder1\folder2"

On Error Resume Next
ChDirNet myNewFolder
If Err.Number <> 0 Then
'what should happen
MsgBox "Please change to your own folder"
Err.Clear
End If
On Error GoTo 0

myFileName = Application.GetOpenFilename(filefilter:="CSV Files, *.CSV", _
Title:="Pick a File")

ChDirNet myCurFolder

If myFileName = False Then
MsgBox "Ok, try later" 'user hit cancel
Exit Sub
End If

'do a bunch of work

End Sub

 

[ker_01]

I got it-

Private Declare Function SetCurrentDirectoryA _
Lib "kernel32" (ByVal lpPathName As String) As Long

and

SetCurrentDirectoryA(sDirDefault)

 

[phil K]

Hi Dave,

I am having trouble with replacing the ChDrive function with the windows API. Would you be able to help me here? The Excel needs to be saved on a network drive which is not mapped on all computers.
I tried entering the code you have supplied but it will not work.

Thanks for your help!

Phil

Sub export()

Dim fname As Variant
Dim NewWb As Workbook
Dim FileFormatValue As Long


If Val(Application.Version) < 9 Then Exit Sub
If Val(Application.Version) < 12 Then




fname = Application.GetSaveAsFilename(InitialFileName:=Range("D143"), _
filefilter:="Excel Files (*.xls), *.xls", _
Title:="This example copies the ActiveSheet to a new workbook")

If fname <> False Then

ActiveSheet.Copy
Set NewWb = ActiveWorkbook


NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing

End If
Else

fname = Application.GetSaveAsFilename(InitialFileName:=Range("D143"), filefilter:= _
" Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
" Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
" Excel 2000-2003 Workbook (*.xls), *.xls," & _
" Excel Binary Workbook (*.xlsb), *.xlsb", _
FilterIndex:=1, Title:="This example copies the ActiveSheet to a new workbook")


If fname <> False Then
Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
Case "xls": FileFormatValue = 56
Case "xlsx": FileFormatValue = 51
Case "xlsm": FileFormatValue = 52
Case "xlsb": FileFormatValue = 50
Case Else: FileFormatValue = 0
End Select


If FileFormatValue = 0 Then
MsgBox "Sorry, unknown file extension"
Else

ActiveSheet.Copy
Set NewWb = ActiveWorkbook


NewWb.SaveAs fname, FileFormat:= _
FileFormatValue, CreateBackup:=False

Set NewWb = Nothing

End If
End If
End If

End Sub

 

[Dave Peterson]

Try including the UNC path in the initialfilename parm. I can't tell if it's
part of that value in that D143 cell.

(Untested.)