![]() |
ChDrive and ChPath to a network drive
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 |
ChDrive and ChPath to a network drive
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 wrote: 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 |
ChDrive and ChPath to a network drive
I got it-
Private Declare Function SetCurrentDirectoryA _ Lib "kernel32" (ByVal lpPathName As String) As Long and SetCurrentDirectoryA(sDirDefault) :) "ker_01" wrote: 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 |
Yep. ChDrive and ChDir are limited to those mapped drives.
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:=Ran ge("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:=Ran ge("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 On Friday, March 26, 2010 6:09 PM ker_01 wrote: 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 am testing against the real path (LAN location), I am getting an error on ChDrive. I am 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 is not 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 does not work twb.Close SaveChanges:=False Application.DisplayAlerts = True On Friday, March 26, 2010 6:25 PM Dave Peterson wrote: Yep. ChDrive and ChDir are limited to those mapped drives. But Windows supplies an API that will 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 wrote: On Friday, March 26, 2010 6:27 PM ker_01 wrote: I got it- Private Declare Function SetCurrentDirectoryA _ Lib "kernel32" (ByVal lpPathName As String) As Long and SetCurrentDirectoryA(sDirDefault) "ker_01" wrote: |
Yep. ChDrive and ChDir are limited to those mapped drives.
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.) On 05/06/2011 06:01, phil K wrote: 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:=Ran ge("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:=Ran ge("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 On Friday, March 26, 2010 6:09 PM ker_01 wrote: 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 am testing against the real path (LAN location), I am getting an error on ChDrive. I am 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 is not 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 does not work twb.Close SaveChanges:=False Application.DisplayAlerts = True On Friday, March 26, 2010 6:25 PM Dave Peterson wrote: Yep. ChDrive and ChDir are limited to those mapped drives. But Windows supplies an API that will 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 wrote: On Friday, March 26, 2010 6:27 PM ker_01 wrote: I got it- Private Declare Function SetCurrentDirectoryA _ Lib "kernel32" (ByVal lpPathName As String) As Long and SetCurrentDirectoryA(sDirDefault) "ker_01" wrote: -- Dave Peterson |
All times are GMT +1. The time now is 11:12 PM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com