I need to write a script to save a worksheet with to a predetermined location and the save name is filled from values within the worksheet. I can get it to save in the proper location, but the file name returns a combination of FATPMetiFolderPath and FATPMetiPath (\Volumes\MFS1\Groups\METI...\METIman\MMP0123 - FATP.xlsm). I can do this just fine with Windows Excel VBA, but I have never used a Mac before. I am programming on a PC, but it needs to be able to be saved properly if used on a Mac.
Sub saveFATPMMMac()
'Saves copy for access for everyone
Dim FATPMetiPath As String
Dim FATPMetiFolderPath As String
FATPMetiFolderPath = "\Volumes\MFS1\Groups\METI\Quality Control\Function and Acceptance Test Documents\METIman\"
'FATPMetiFolderPath = "C:\Users\gzapantis\Desktop\"
FATPMetiPath = FATPMetiFolderPath & _
Sheets("Failure Report").Range("FailReportSN").Text & " - FATP " & ".xlsm"
ThisWorkbook.SaveAs Filename:=FATPMetiPath
End Sub
I have solved the problem. It saves it with the correct file name and in the correct location.
Sub saveFATPMMMac()
'Saves copy for access for everyone
Dim FATPMetiPath As String
Dim FATPMetiFolderPath As String
If Application.PathSeparator = ":" Then
FATPMetiFolderPath = "Volumes:MFS1:Groups:METI:Quality Control:Function and Acceptance Test Documents:METIman:"
Else
FATPMetiFolderPath = "F:\Groups\METI\Quality Control\Function and Acceptance Test Documents\METIman\"
End If
FATPMetiPath = FATPMetiFolderPath & _
Sheets("Failure Report").Range("FailReportSN").Text & " - FATP.xlsm"
ThisWorkbook.SaveAs Filename:=FATPMetiPath
End Sub
Thank you for pointing me in the right direction.
Related
I'm trying to write a function to compare date modified on the server file to the client's and overwrite the client file if it is older. This runs as part of a Group Policy startup script. The tmp flies are created as a debugging step to see where the code is getting stuck. copyfile.tmp is created but copydone.tmp is not. None of the files are read-only, and this runs under the local SYSTEM context, which has all the access it needs.
The files all exist. I've successfully copied the server file to the client earlier in the script if the client didn't have one. (oFSO is a file system object, strWinTemp is the system's temp directory in Windows; defined earlier)
'Replace clientfile if older than servfile
Sub GetNewerFile(clientfile,servfile)
Dim dtmLocalDate
Dim dtmServerDate
Dim oLocalFile
Dim oServerFile
Set oLocalFile = oFSO.GetFile(clientfile)
dtmLocalDate = oLocalFile.DateLastModified
Set oServerFile = oFSO.GetFile(servfile)
dtmServerDate = oServerFile.DateLastModified
If Not oFSO.FileExists(strWinTemp & "\" & "getnewerfile.tmp") Then oFSO.CreateTextFile(strWinTemp & "\" & "getnewerfile.tmp")
If DateDiff("d", dtmServerDate, dtmLocalDate) > 0 Then
'dtmServerDate is more recent than dtmLocalDate, comparison by "day"
If Not oFSO.FileExists(strWinTemp & "\" & "copyfile.tmp") Then oFSO.CreateTextFile(strWinTemp & "\" & "copyfile.tmp")
oFSO.CopyFile oServerFile, oLocalFile, 1
If Not oFSO.FileExists(strWinTemp & "\" & "copydone.tmp") Then oFSO.CreateTextFile(strWinTemp & "\" & "copydone.tmp")
End If
End Sub
I replaced the lines between the DateDiff check and End Sub with this:
If oFSO.FileExists(clientfile) then oFSO.DeleteFile(clientfile)
oFSO.CopyFile servfile, clientfile, TRUE
I must be crazy for trying to use Excel (2015? It says copyright 2015) VBA on OSX. I'm trying to have Excel query some text files, called 33.txt, 34.txt, etc. in the same folder as my workbook. It chooses the file according to numbers in Column A. Excel gives me this error message: "Excel cannot find the text file to refresh this external data range.Check to make sure the text file has not been moved or renamed, then try the refresh again."
fileloc = ActiveWorkbook.Path & "/" & Range("A" & j) & ".txt"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileloc, Destination:=Range("P1"))
.AdjustColumnWidth = False
.RefreshStyle = xlOverwriteCells
.Refresh BackgroundQuery:=False
End With
To make matters more frustrating, when I debug.print fileloc, it looks right. It looks like the exact location of the text file I want it to query.
Oh man I got it, with help from here: VBA: .Refresh Run-Time Error
' Get the URL
fpath = ActiveWorkbook.Path
f_dummy = fpath & "/" & Range("A" & j) & ".txt"
fname = Dir(f_dummy)
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fpath & "/" & fname, Destination:=Range("P1"))
.AdjustColumnWidth = False
.RefreshStyle = xlOverwriteCells
.Refresh 'BackgroundQuery:=False
End With
Ok, so we need to create a GPO that allows our users to only use specific programs.
GPO Location:
User Configuration
Policies
Administrative Templates [...]
System
Run only specified Windows applications
Then setting the GPO to enabled and clicking on List of allowed applications --> Show...
I have created an excel spreadsheet containing the names of all the programs and their associated executable files with other pertinent information so that we can easily organize, add, delete, etc. the executable files that we need to allow our users access to.
This spreadsheet then dumps all the executable files into a text file.
Here is an example of what the text file looks like:
Acrobat.exe
chrome.exe
calc.exe
.
.
.
There are a lot of entries and these are likely subject to change. What I am trying to do is create a script that will take that text file and populate the GPO automatically. I don't care if we have to open the window and then run it, it does not need to run from the task scheduler (although that would be amazing if someone has that code ready). We just need it to populate this ridiculous amount of executable filenames into the fields.
Here is code I found (VBScript) that when run, should populate the fields automatically, however I cannot get it to run in the Group Policy Management Editor (it runs in the windows explorer window instead and ends up searching for some of the files)
' Open the text file, located in the same path as the script
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = Mid(Wscript.ScriptFullName, 1, InStrRev(Wscript.ScriptFullName, wscript.ScriptName) -1)
Set objFile = objFSO.OpenTextFile(strPath & "appList.txt")
' Activate the "Show Contents" window with the "List of allowed applications".
' Note the window must be opened already and we should have selected where in
' the list we want to enter the data before running the script
set WshShell = WScript.CreateObject("WScript.Shell")
WScript.Sleep 1000
WshShell.AppActivate "Show Contents"
' Read the file line by line
Do While objFile.AtEndOfStream <> True
' Each line contains one EXE name
exeName = objFile.ReadLine
' Escape forbidden chars { } [ ] ( ) + ^ % ~
exeName = Replace(exeName, "[", "{[}")
exeName = Replace(exeName, "]", "{]}")
exeName = Replace(exeName, "(", "{(}")
exeName = Replace(exeName, ")", "{)}")
exeName = Replace(exeName, "+", "{+}")
exeName = Replace(exeName, "^", "{^}")
exeName = Replace(exeName, "%", "{%}")
exeName = Replace(exeName, "~", "{~}")
' Send the EXE name to the window
WScript.Sleep 100
WshShell.SendKeys exeName
' Move to the next one
WshShell.SendKeys "{TAB}"
Loop
objFile.Close
from: http://blogs.msdn.com/b/alejacma/archive/2011/03/24/how-to-update-quot-run-only-specified-windows-applications-quot-gpo-programmatically-vbscript.aspx
"C:\Windows\System32\GroupPolicy\User\Registry.pol"
Is where my policies are stored. It's a semi text file. Try writing to that file.
Ok, so I tried it many different ways. If anyone is looking for an answer to do this, this is the way I've figured it out and the way I've decided to proceed. I will post all relevant code below.
In Excel, the format of my table is as follows:
(With obviously WAY more entries)
Here is the VBA code I used to turn the data from this file into the proper format for the registry key:
VBA - In Excel
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
StartRow = 2
If SelectionOnly = True Then
With Selection
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
Else
With ActiveSheet.UsedRange
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & Chr(34) & CellValue & ".exe" & Chr(34) & "=" & Chr(34) & CellValue & ".exe" & Chr(34) & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine; ""
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
Sub PipeExport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetSaveAsFilename(InitialFileName:="appList", filefilter:="Text (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = "|"
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Extension: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=False
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
PipeExport
End Sub
The file that is created is appList.txt and its format is the same format as the registry key:
"Acrobat.exe"="Acrobat.exe"
"AcroRd32.exe"="AcroRd32.exe"
Now in your GPO, add a unique program name to the allowed applications list (say test1234.exe) and in your registry editor, go to Edit > Find test1234.exe.
Export that registry key under File > Export. Remove the test1234.exe line and paste in your text file. Then reimport that file and you're done!
Access 2013 does not support ADP. Some alternatives to ADPs are given:
Convert the ADP to a linked Access Desktop Database.
Import objects into an ACCDE file and then create linked tables to the existing data by using an earlier version of Access.
My ADP contains only Forms, Reports, Macros and Modules. I want to use this ADP in Access 2013 (not on any earlier version of Access).
I have not found any method to convert ADP to a linked Access Desktop Database or to Import objects into an ACCDE file on Access 2013.
How can I convert an ADP to a linked Access Desktop Database or to Import objects into an ACCDE file using Access 2013?
How can I convert an ADP to a linked Access Desktop Database or to Import objects into an ACCDE file using Access 2013?
You can't. Access 2013 won't work with ADP files at all. If you try to import objects from an ADP file in Access 2013, you get the following error:
What you need to do is
find a machine with Access 2010 or earlier,
use it to import the Queries, Forms, etc., from the ADP into an .accdb or .mdb file, then
take that .accdb or .mdb file back to your Access 2013 machine and continue on from there.
edit re: comments
Is there is no way to Convert the ADP to a linked Access Desktop Database using access 2013
Apparently not. Even trying to use VBA to copy a Form object from an .adp file into an .accdb file fails. The following code:
Option Compare Database
Option Explicit
Sub adpImportTest()
Dim dbPath As String, formName As String
On Error GoTo adpImportTest_Error
Debug.Print "Try importing a form from an .accdb file..."
dbPath = "C:\Users\Gord\Documents\accdbTest.accdb"
formName = "myCustomers"
DoCmd.TransferDatabase acImport, "Microsoft Access", dbPath, acForm, formName, formName
Debug.Print "Import succeeded."
Debug.Print
Debug.Print "Try importing a form from an .adp file..."
dbPath = "C:\Users\Gord\Documents\NorthwindCS.adp"
formName = "Customers"
DoCmd.TransferDatabase acImport, "Microsoft Access", dbPath, acForm, formName, formName
Debug.Print "Import succeeded."
Exit Sub
adpImportTest_Error:
Debug.Print Err.Description
End Sub
...produces the following result:
Try importing a form from an .accdb file...
Import succeeded.
Try importing a form from an .adp file...
The search key was not found in any record.
If we try to get sneaky and rename the .adp file to .mdb then Access 2013 won't read it:
As I said, you need to use Access 2010 (or older) to extract the objects from the .adp file into an .accdb or .mdb file. Then you can work with the .accdb or .mdb file in Access 2013.
Using office<2013 eg 2010 2007
Try using save as text / load from text to transfer forms
You can then edit the text files preparing recordsources for your accdb linked tables.
Partial and uncleaned code but gives you an idea
module LoadSaveForm:
Option Compare Database
Option Base 0
Option Explicit
Dim path$
Dim DateTimeString$
Dim app As Access.Application
Function SaveFormAsText(FormName As String) As Boolean
Dim sPath As String
Access.SaveAsText acForm, FormName, "C:\Temp" & "\" & FormName & ".txt"
End Function
Function LoadFormFromText(FormName As String)
Access.LoadFromText acForm, FormName, "C:\Temp" & "\" & FormName & ".txt"
End Function
Private Sub SaveMDBObjectsAsText()
DateTimeString = Format(Now(), "yyyymmddhhnn")
path = CurrentProject.path & "\" '& "AS_TEXT_" & DateTimeString & "\"
If Dir(path) <> "" Then
'It exists
Else
On Error Resume Next
MkDir path
On Error GoTo 0
End If
SaveDataAccessPagesAsText
SaveFormsAsText
SaveReportsAsText
SaveModulesAsText
'SaveQueriesAsText
CreateProjectFromText (path)
End Sub
Public Sub CreateProjectFromText(pathString As String)
path = pathString
'SaveMDBBase
SaveAccdbDBase
LoadDataAccessPagesFromText
LoadFormsFromText
LoadReportsFromText
LoadModulesFromText
'LoadQueriesFromText
On Error Resume Next
Dim r As Reference
With app
With .CurrentProject
path = .FullName
End With
For Each r In .References
With r
If Not .BuiltIn Then
app.References.Remove r
End If
End With
Next r
For Each r In References
With r
If Not .BuiltIn Then
app.References.AddFromGuid r.GUID, r.Major, r.Minor
End If
End With
Next r
.RunCommand acCmdSaveAllModules
.RunCommand acCmdCompileAndSaveAllModules
.CloseCurrentDatabase
.SysCmd 603, path, Replace(Replace(Replace(path, ".accdb", ".accde"), ".adp", ".ade"), ".mdb", ".mde")
.Quit
End With
Set app = Nothing
MsgBox "All Done with Text Backup"
End Sub
Private Sub SaveDataAccessPagesAsText()
Dim filename$
Dim Name$
Dim DataAccessPage As AccessObject
For Each DataAccessPage In CurrentProject.AllDataAccessPages
Name = DataAccessPage.Name
filename = path & Name & ".txt"
SaveAsText acDataAccessPage, Name, filename
Next DataAccessPage
End Sub
Private Sub SaveFormsAsText()
Dim filename$
Dim Name$
Dim Form As AccessObject
For Each Form In CurrentProject.AllForms
Name = Form.Name
filename = path & Name & ".txt"
SaveAsText acForm, Name, filename
Next Form
End Sub
Private Sub SaveReportsAsText()
Dim filename$
Dim Name$
Dim Report As AccessObject
For Each Report In CurrentProject.AllReports
Name = Report.Name
filename = path & Name & ".txt"
SaveAsText acReport, Name, filename
Next Report
End Sub
Private Sub SaveMacrosAsText()
Dim filename$
Dim Name$
Dim Macro As AccessObject
For Each Macro In CurrentProject.AllMacros
Name = Macro.Name
filename = path & Name & ".txt"
SaveAsText acMacro, Name, filename
Next Macro
End Sub
Private Sub SaveModulesAsText()
Dim filename$
Dim Name$
Dim Module As AccessObject
For Each Module In CurrentProject.AllModules
Name = Module.Name
filename = path & Name & ".txt"
SaveAsText acModule, Name, filename
Next Module
End Sub
Private Sub SaveQueriesAsText()
Dim filename$
Dim Name$
Dim GetQueryNames As ADODB.Recordset
Set GetQueryNames = CurrentProject.connection.OpenSchema(adSchemaViews)
With GetQueryNames
Do While Not .EOF
Name = .Fields("TABLE_NAME")
filename = path & Name & ".txt"
SaveAsText acQuery, Name, filename
.MoveNext
Loop
End With
End Sub
Private Function SaveAccdbDBase() As Database
Dim ws As DAO.Workspace
Dim db As DAO.Database
'Get default Workspace
Set ws = DBEngine.Workspaces(0)
Dim filename$
Dim Name$
Name = Replace(CurrentProject.Name, CurrentProject.path, "")
If Name Like "*.adp" Then
Name = Replace(Name, "adp", "accdb")
Else
Name = Replace(Name, "accdb", "adp")
End If
filename = path & Name
'Make sure there isn't already a file with the name of the new database
If Dir(filename) <> "" Then Kill filename
Set app = CreateObject("Access.Application")
'Create a new mdb file
If Name Like "*.adp" Then
Application.CreateAccessProject filename, getConnection.ConnectionString
Else
Set db = ws.CreateDatabase(filename, dbLangGeneral)
End If
db.Close
Set db = Nothing
'SaveAsText 6, "", filename
If Name Like "*.adp" Then
app.Visible = True
app.UserControl = True
app.OpenAccessProject filename
Else
app.OpenCurrentDatabase filename
End If
app.SetOption "Show Navigation Pane Search Bar", True
Set SaveAccdbDBase = db
End Function
Private Sub LoadDataAccessPagesFromText()
Dim filename$
Dim Name$
Dim DataAccessPage As AccessObject
For Each DataAccessPage In CurrentProject.AllDataAccessPages
Name = DataAccessPage.Name
filename = path & Name & ".txt"
app.LoadFromText acDataAccessPage, Name, filename
Next DataAccessPage
End Sub
Private Sub LoadFormsFromText()
Dim filename$
Dim Name$
Dim Form As AccessObject
For Each Form In CurrentProject.AllForms
Name = Form.Name
filename = path & Name & ".txt"
On Error Resume Next
app.LoadFromText acForm, Name, filename
Next Form
End Sub
Sub CreateNewMDBFile()
Dim ws As Workspace
Dim db As Database
Dim LFilename As String
'Get default Workspace
Set ws = DBEngine.Workspaces(0)
'Path and file name for new mdb file
LFilename = "c:\NewDB.mdb"
'Make sure there isn't already a file with the name of the new database
If Dir(LFilename) <> "" Then Kill LFilename
'Create a new mdb file
Set db = ws.CreateDatabase(LFilename, dbLangGeneral)
'For lookup tables, export both table definition and data to new mdb file
DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "Lookup Table1", "Lookup Table1", False
'For data entry tables, export only table definition to new mdb file
DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "DataEntry Table1", "DataEntry Table1", True
db.Close
Set db = Nothing
End Sub
Run SaveMDBObjectsAsText() to get an idea of what happens
How do I save an entire VB6 project to a new folder? Modules and all. I'm in a position where I need to work with some old VB6 projects. I'd like to save them to a new folder but when I save the project, all that is saved is the vbp file. No modules, no frm files. I want to be able to save all the info to a single folder without moving each BAS file one at a time. Is this even possible?
Addition: The first 2 replies make good sense. But my problem is that the BAS modules seem to be scattered all over the place. Making Windows Explorer do the work a bit tricky. If I have to I will but was looking for an easier way.
Thanks
Given the new "addition" to the question:
Move the VBP and the files in Windows Explorer to a completely new directory.
Open the VBP in a text editor and change any absolute paths to relative paths. VBP files are simple text files, and the format is even documented in the VB6 manual.
Here's an example. This evil VBP below has many absolute paths
Type=Exe
Form=c:\who\knows\where\B_Form.frm
Module=CModule; z:\magic\mapped\network\drive\heehee\C_Module.bas
Class=DClass; x:\personal\usb\stick\D_Class.cls
It would be changed to this benign VBP, which references local copies of the files. You can use relative paths for subdirectories.
Type=Exe
Form=B_Form.frm
Module=CModule; C_Module.bas
Class=DClass; subdirectory\D_Class.cls
If you mean from within Visual Studio, I don't think you can except by doing Save As for each file...
But the simpler approach is to just use Windows Explorer and copy the whole folder structure for the solution into another folder, (or do a recursive "Get" from your source code repository to a different local destination), and then open the solution or project file in the new location... The pointers in the project file that tell Visual Studio where 5all the individual source code and other files are located are generally all stored as relative paths, relative to the folder that the project file is in...
It's been a while since I used VB6, but I'd be tempted to move them using Windows Explorer, then manually edit the VBP file to point to the new locations afterwards. If I remember right, relative paths are fine in the VBP, so you may not even need to manke any changes.
Unbind from source control, if capable/appropriate.
Check into source control as a brand new solution/project
Recursive 'get' from your SCM into a new directory.
There's your new copy.
Create a VB6 Add-in. You can download it from: http://pan.baidu.com/s/1CXO3k
Or you can use below code to create your own.
Option Explicit
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Private Sub CancelButton_Click()
Connect.Hide
End Sub
Private Sub OKButton_Click()
On Error Resume Next
Dim strProject As String
Dim strPath As String
Dim strPath2 As String
Dim strFile As String
Dim strPrjFile As String
Dim rst As VbMsgBoxResult
Dim m, n As Long
Dim col2 As Collection, col As Collection
Dim vbCom As VBComponent
Dim fso As FileSystemObject
Dim ts As TextStream
Dim f1 As String, f2 As String
strProject = Me.VBInstance.ActiveVBProject.FileName
strPath = ParseFileName(strProject, strPrjFile)
strPath2 = setFolder
If strPath = "" Or strPath = strPath2 Then
MsgBox "target folder is invalid or same as the project folder. Can't copy."
Exit Sub
End If
Set col2 = New Collection
Set col = New Collection
Set fso = New FileSystemObject
Set ts = fso.CreateTextFile(strPath2 & "\wemeet.log", False)
For m = Me.VBInstance.ActiveVBProject.VBComponents.Count To 1 Step -1
Set vbCom = Me.VBInstance.ActiveVBProject.VBComponents(m)
For n = 1 To vbCom.FileCount
f1 = vbCom.FileNames(n)
ParseFileName f1, strFile
f2 = strPath2 & "\" & strFile
fso.CopyFile f1, f2
col.Add f1
col2.Add f2
ts.WriteLine "" & Now() & " [Move]: " & f1
ts.WriteLine "" & Now() & " [To ]: " & f2
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.VBComponents.Remove vbCom
Next
For m = 1 To col2.Count
Me.VBInstance.ActiveVBProject.VBComponents.AddFile col2.Item(m)
ts.WriteLine "" & Now() & " [Add]: " & col2.Item(m)
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.SaveAs strPath2 & "\" & strPrjFile
ts.WriteLine "" & Now() & " [SaveAs]: " & strPath2 & "\" & strPrjFile
ts.WriteBlankLines 1
ts.Close
fso.OpenTextFile strPath2 & "\wemeet.log"
Set fso = Nothing
Set col = Nothing
Set col2 = Nothing
Set vbCom = Nothing
Connect.Hide
End Sub
Private Function ParseFileName(ByVal sPath As String, ByRef sFile As String) As String
Dim fso As New FileSystemObject
If fso.FileExists(sPath) Then
ParseFileName = fso.GetParentFolderName(sPath)
sFile = fso.GetFileName(sPath)
Else
ParseFileName = ""
sFile = ""
End If
Set fso = Nothing
End Function
Private Function setFolder() As String
Dim objDlg As Object
Dim objStartFolder As Object
Set objDlg = CreateObject("Shell.Application")
Set objStartFolder = objDlg.BrowseForFolder(&H0, "Select a folder", &H10 + &H1)
If InStr(1, TypeName(objStartFolder), "Folder") > 0 Then
setFolder = objStartFolder.ParentFolder.ParseName(objStartFolder.Title).Path
End If
Set objDlg = Nothing
End Function