I am attempting to import data into my MS Access project via TransferText, but am receiving error #3051: "The Microsoft Access database engine cannot open or write to the file ''. It is already opened exclusively by another user, or you need permissions to view and write its data."
It is odd to me that the filename given in the error message is blank. I have checked and rechecked the file name, even to perform a check "If Not fso.FileExists(file_name) Then ... End If" prior to the TransferText call.
I have also checked and rechecked the table name and the file permissions. The table is successfully emptied before the TransferText call, so I know that works. The file is in a subfolder relative to the Access database file in a folder on my desktop. I have not set or unset any permissions for any of the folders or files.
Until now I had been using DoCmd.TransferSpreadsheet to import the data that is downloaded from a web based tool, but I found Excel was misinterpreting some alphanumeric codes as numbers in scientific format, such as 1E100 would become 1E+100 in the Excel file, so the data was corrupted before getting to the Access database. These codes are getting corrupted in uncorrectable ways, so I can't modify the data after import. I found I could save the data from the web tool as a CSV file rather than an Excel file; this led me to try to use DoCmd.TransferText.
Below is the code I am using:
Private Function ImportExcel( _
ByVal file_name As String, _
ByVal table_name As String _
) As Integer
On Error GoTo Error
Dim fso As FileSystemObject, folder_name As String
Dim xl_book As Excel.Workbook
Dim xl_sheet As Excel.Worksheet
Dim i As Integer
' suppress excel's file-not-found popup
Set fso = New FileSystemObject
If Not fso.FileExists(file_name) Then
ImportExcel = -1
GoTo Finish
End If
' gets a workbook from a global application object
Set xl_book = Util.GetExcelWorkbook( _
file_name:=file_name, _
visible:=False, _
use_cache:=True _
)
If xl_book Is Nothing Then
ImportExcel = -1
GoTo Finish
End If
' always use the first worksheet
Set xl_sheet = xl_book.Sheets(1)
' fake the first record to force columns types
xl_sheet.range("A2").EntireRow.Insert
For i = 1 To xl_sheet.UsedRange.columns.count
xl_sheet.Cells(2, i) = "test"
Next i
' make sure the table is closed
DoCmd.Close _
ObjectType:=acTable, _
ObjectName:=table_name, _
Save:=acSaveNo
' link to file
DoCmd.SetWarnings False
If ".csv" = Right(file_name, 4) Then
' empty table
DoCmd.RunSQL "DELETE * FROM " & table_name, True
' import data
Debug.Print table_name
Debug.Print file_name
DoCmd.TransferText _
TransferType:=acImportDelim, _
SpecificationName:=table_name & " Import Spec", _
TableName:=table_name, _
FileName:=file_name, _
HasFieldNames:=True
Else
' delete table
On Error Resume Next
DoCmd.DeleteObject _
ObjectType:=acTable, _
ObjectName:=table_name
If 0 <> Err.Number Then
Resume Next
End If
On Error GoTo Error
' import data
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
TableName:=table_name, _
FileName:=file_name, _
HasFieldNames:=True, _
range:=xl_sheet.NAME() & "!" & _
xl_sheet.range( _
xl_sheet.Cells(1, 1), _
xl_sheet.Cells( _
xl_sheet.UsedRange.rows.count, _
xl_sheet.UsedRange.columns.count _
) _
).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
SpreadsheetType:=acSpreadsheetTypeExcel9
End If
DoCmd.SetWarnings True
Finish:
Set xl_sheet = Nothing
If Not xl_book Is Nothing Then
xl_book.Close SaveChanges:=False
End If
Set xl_book = Nothing
Set fso = Nothing
Exit Function
Error:
Resume Finish
End Function
The two Debug.Print calls just prior to the DoCmd.TransferText call print exactly what is expected.
I have a project I work on frequently, the data comes in Access & I need to export to Excel. The following code always worked until my company upgraded to Windows 2010 a couple of years ago. What happens is I'll point to the subdir I want (e.g. P:\project\evaluation\output) and it will save one subdir up (e.g. P:\project\evaluation).
The code:
Sub ExporttoXL()
Dim response, today
exportdir = fncOpenFolder()
today = Format(Date, "mmddyy")
response = InputBox("What is the date for the title of the output file? (Recommend: mmddyy format)", "Output file date for name", today)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"Query001", "Output-" & response & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"Query002", "Output-" & response & ".xls"
End Sub
----------------
Public Function fncOpenFolder() As String
Dim fdlg As Object
Set fdlg = Application.FileDialog(4) 'msoFileDialogFolderPicker
With fdlg
.AllowMultiSelect = False
.Title = "Select Folder"
If .Show = -1 Then
fncOpenFolder = .SelectedItems(1)
Else
fncOpenFolder = ""
End If
End With
Set fdlg = Nothing
End Function
The FileName argument to TransferSpreadsheet is supposed to be "the file name and path of the spreadsheet you want to import from, export to, or link to." But your code is giving it only the file name without the path. The exportdir variable is not used after you give it a value from fncOpenFolder().
Revise the code and use exportdir to include the path with the file name for the workbook which you want as the export target ...
Dim strFullPath As String
strFullPath = exportdir & "\Output-" & response & ".xls"
Debug.Print strFullPath '<- view this in Immediate window; Ctrl+g will take you there
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
' "Query001", "Output-" & response & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"Query001", strFullPath
I'm trying to export the results of a dynamic SQL statement but keep getting the error 3027 "Cannot update. Database or object is read-only.". I'm using Access 2003. GetYearFromDirName(sFolder) is parsing out a year from a directory structure and using that as a calculated column in the SQL results.
Here is the code in question:
sSQL = "SELECT INDEXDB1.IFIELD1 AS TestArea, INDEXDB1.IFIELD2 AS TSID, INDEXDB1.IFIELD3 AS MapCoord, " _
& "INDEXDB1.IFIELD4 AS Community, INDEXDB1.IFIELD5 AS Address, INDEXDB1.IFIELD6 AS DocNum, " _
& "'" & GetYearFromDirName(sFolder) & "' AS Yr FROM INDEXDB1;"
'DoCmd.TransferSpreadsheet acExport, , sSQL, sFolder & "\" & BoxNum & ".csv"
'DoCmd.OutputTo acOutputQuery, "ExportRecs", acFormatXLS, sFolder & "\" & BoxNum & ".csv"
SaveToExcel sSQL, sFolder & "\" & BoxNum & ".csv"
Calls:
Public Sub SaveToExcel(strSQL As String, strFullFileName As String)
Dim strQry As String
Dim db As Database
Dim Qdf As QueryDef
On Error GoTo SaveToExcel_err
strQry = "TempQueryName"
Set db = CurrentDb
'Set Qdf = db.CreateQueryDef(strQry, strSQL)
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, strQry, strFullFileName, True
'DoCmd.DeleteObject acQuery, strQry
With db
' Create permanent QueryDef.
Set Qdf = .CreateQueryDef(strQry, strSQL)
' Open Recordset and print report.
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel3, strQry, strFullFileName, True
' Delete new QueryDef because this is a demonstration.
.QueryDefs.Delete Qdf.Name
.Close
End With
Exit Sub
SaveToExcel_err:
MsgBox Error & " " & Err & " in sub SaveToExcel. Close program and start over."
End Sub
Is there a better way to export dynamic SQL statement results? In the end, I need a CSV file.
You may open it in Excel, but CSV is a text format, so you need to use DoCmd.TransferText instead of DoCmd.TransferSpreadsheet. Manually go through the export once using the Export Data Wizard. As you do so, you'll wand to create and name a Export Specification. This will specify commas as the delimiter and double quotes as text delimiters. The name of the export spec you created is passed as the second argument to TransferText.
I'm making a very basic data entry and database system application using excel (for bulk data entry) and Access (to house the data). I play to distribute it as a zip file. In order for it to work I need the file structure to remain unchanged and to unzip to c:/ drive. Is there anyway to force a zip file to unzip to a specific location?
The reason I need this is to automate the uploading of entered data. As far as I know in Access VBA you have to specify full filepaths in VBA to import data.
* Update
Thanks to Remou for getting me out of the woods. Just for posterity's sake this is how I solved it. not the prettiest code but it does the job. First the import function and then the export function.
Importing, a naming convention is still need for the files being uploaded but they can come from anywhere. That file name relates to the tables they will be stored in. At the back end of the excel sheets the data input sheet is split into two (Rec and Occ)
Code as follows:
Function importData_Click(Optional varDirectory As String, _
Optional varTitleForDialog As String) As String
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As String
Dim strFileName As String
Dim strTableName As String
Dim strColumnName As String
Dim The_Year As Long
Dim occNumber As Long
'Get combobox value and assign relavent values to occNumber
The_Year = Forms![Upload Data]!Year_Combo.value
'Ask the to check value
If MsgBox("Uploading " & The_Year & " data" & vbCrLf & "Continue?", VbMsgBoxStyle.vbYesNo) = 7 Then
Exit Function
End If
If The_Year = 2012 Then
occNumber = 1000
ElseIf The_Year = 2013 Then
occNumber = 2000
End If
' Specify that the chosen file must already exist,
' don't change directories when you're done
' Also, don't bother displaying
' the read-only box. It'll only confuse people.
lngFlags = ahtOFN_FILEMUSTEXIST Or _
ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
If IsMissing(varDirectory) Then
varDirectory = ""
End If
If IsMissing(varTitleForDialog) Then
varTitleForDialog = ""
End If
strFilter = ahtAddFilterItem("Excel Files (*.xlsx)", "*.xlsx")
varFileName = ahtCommonFileOpenSave( _
openFile:=True, _
InitialDir:=varDirectory, _
Filter:=strFilter, _
Flags:=lngFlags, _
DialogTitle:=varTitleForDialog)
If Not IsNull(varFileName) Then
varFileName = TrimNull(varFileName)
End If
importData_Click = varFileName
'Sets filename
strFileName = Dir(varFileName)
'Sets TableName
strTableName = Left(strFileName, 4)
If IsNull(strFileName) Then
MsgBox "Upload cancelled"
Exit Function
End If
'Checks naming convetions of filenames
If strTableName Like "*MN" Or strTableName Like "*OP" Or strTableName Like "*DA" Or strTableName Like "*TR" Then
'Checks if data is Opportunistic
If strTableName Like "*OP" Then
strColumnName = "Year_" & strTableName
'Checks to see if that year's data already exists
If DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & The_Year & "") Then
MsgBox "2012 data is already present"
ElseIf DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & The_Year & "") Then
MsgBox "2013 data is already present"
Else
'Uploads data to relevant table
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTableName & "_Rec", varFileName, True, "Rec_Prep$"
MsgBox "Upload successful"
End If
Exit Function
Else
strColumnName = "Occasion_" & strTableName
'Checks Occasions to see if that year exists
If DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & occNumber & "") Then
MsgBox "2012 data is already present"
ElseIf DLookup(strColumnName, strTableName & "_Rec", "" & strColumnName & " = " & occNumber & "") Then
MsgBox "2013 data is already present"
Else
'Uploads to Records table and Occasion table
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTableName & "_Occ", varFileName, True, "Occ_Prep$"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, strTableName & "_Rec", varFileName, True, "Rec_Prep$"
MsgBox "Upload successful"
End If
End If
Else
MsgBox "Your file is named incorrectly! & vbCrLf & Please refer to the Data Dictionary & vbCrLf & for correct naming conventions"
Exit Function
End If
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "BaMN_AllData", strSaveFileName
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
TrimNull = Left(strItem, intPos - 1)
Else
TrimNull = strItem
End If
End Function
Then the export uses the names of command buttons (that match table names) to export to wherever the user wants:
Dim queryYear As Variant
'Function to export data to location of users choice. Query name is automatically detected from the control button used
'Year is derived from the combobox value on [Extract Data] form, null value defaults to all years.
Function exportData_Click()
Dim strFilter As String
Dim strSaveFileName As String
Dim The_Year As Variant
Dim ctlCurrentControl As Control
Dim queryName As String
'Get the name of the control button clicked (corresponds to query name to be run)
Set ctlCurrentControl = Screen.ActiveControl
queryName = ctlCurrentControl.Name
'Get combobox value and assign relavent values to The_Year
The_Year = Forms![Extract Data]!Extract_Year.value
'Change the year from a variant to what we need in the SQL
If The_Year Like "20*" Then
The_Year = CInt(The_Year)
MsgBox The_Year & "Data Type = " & VarType(The_Year)
Else: The_Year = "*"
MsgBox The_Year & "Data Type = " & VarType(The_Year)
End If
'Set queryYear variable
setYear (The_Year)
'Check the variable is correct
'MsgBox getYear()
'Open the Save as Dialog to choose location of query save
strFilter = ahtAddFilterItem("Excel Files (*.xlsx)", "*.xlsx")
strSaveFileName = ahtCommonFileOpenSave( _
openFile:=False, _
Filter:=strFilter, _
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, queryName, strSaveFileName
End Function
'Function to set queryYear used in data extraction queries
Public Function setYear(The_Year As Variant)
queryYear = The_Year
End Function
'Function to get queryYear used in data extraction queries
Function getYear()
getYear = queryYear
End Function
It should be noted that the file save and file open code sections are not mine. They come from Ken Getz and the whole code can be found here:
http://access.mvps.org/access/api/api0001.htm
It would be better to use the application path ( eg currentproject.Path ) or to ask the user to specify a location for the data store rather than to try to force an install at a location that may not be available to the user. There is no need at all to hard-code paths. In Access, you can store information relevant to the project in a table, including the data path. You can look up MS Access from Excel.
I want to click a button on my access form that opens a folder in Windows Explorer.
Is there any way to do this in VBA?
You can use the following code to open a file location from vba.
Dim Foldername As String
Foldername = "\\server\Instructions\"
Shell "C:\WINDOWS\explorer.exe """ & Foldername & "", vbNormalFocus
You can use this code for both windows shares and local drives.
VbNormalFocus can be swapper for VbMaximizedFocus if you want a maximized view.
The easiest way is
Application.FollowHyperlink [path]
Which only takes one line!
Thanks to PhilHibbs comment (on VBwhatnow's answer) I was finally able to find a solution that both reuses existing windows and avoids flashing a CMD-window at the user:
Dim path As String
path = CurrentProject.path & "\"
Shell "cmd /C start """" /max """ & path & """", vbHide
where 'path' is the folder you want to open.
(In this example I open the folder where the current workbook is saved.)
Pros:
Avoids opening new explorer instances (only sets focus if window exists).
The cmd-window is never visible thanks to vbHide.
Relatively simple (does not need to reference win32 libraries).
Cons:
Window maximization (or minimization) is mandatory.
Explanation:
At first I tried using only vbHide. This works nicely... unless there is already such a folder opened, in which case the existing folder window becomes hidden and disappears! You now have a ghost window floating around in memory and any subsequent attempt to open the folder after that will reuse the hidden window - seemingly having no effect.
In other words when the 'start'-command finds an existing window the specified vbAppWinStyle gets applied to both the CMD-window and the reused explorer window. (So luckily we can use this to un-hide our ghost-window by calling the same command again with a different vbAppWinStyle argument.)
However by specifying the /max or /min flag when calling 'start' it prevents the vbAppWinStyle set on the CMD window from being applied recursively. (Or overrides it? I don't know what the technical details are and I'm curious to know exactly what the chain of events is here.)
Here is some more cool knowledge to go with this:
I had a situation where I needed to be able to find folders based on a bit of criteria in the record and then open the folder(s) that were found. While doing work on finding a solution I created a small database that asks for a search starting folder gives a place for 4 pieces of criteria and then allows the user to do criteria matching that opens the 4 (or more) possible folders that match the entered criteria.
Here is the whole code on the form:
Option Compare Database
Option Explicit
Private Sub cmdChooseFolder_Click()
Dim inputFileDialog As FileDialog
Dim folderChosenPath As Variant
If MsgBox("Clear List?", vbYesNo, "Clear List") = vbYes Then DoCmd.RunSQL "DELETE * FROM tblFileList"
Me.sfrmFolderList.Requery
Set inputFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With inputFileDialog
.Title = "Select Folder to Start with"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
folderChosenPath = .SelectedItems(1)
End With
Me.txtStartPath = folderChosenPath
Call subListFolders(Me.txtStartPath, 1)
End Sub
Private Sub cmdFindFolderPiece_Click()
Dim strCriteria As String
Dim varCriteria As Variant
Dim varIndex As Variant
Dim intIndex As Integer
varCriteria = Array(Nz(Me.txtSerial, "Null"), Nz(Me.txtCustomerOrder, "Null"), Nz(Me.txtAXProject, "Null"), Nz(Me.txtWorkOrder, "Null"))
intIndex = 0
For Each varIndex In varCriteria
strCriteria = varCriteria(intIndex)
If strCriteria <> "Null" Then
Call fnFindFoldersWithCriteria(TrailingSlash(Me.txtStartPath), strCriteria, 1)
End If
intIndex = intIndex + 1
Next varIndex
Set varIndex = Nothing
Set varCriteria = Nothing
strCriteria = ""
End Sub
Private Function fnFindFoldersWithCriteria(ByVal strStartPath As String, ByVal strCriteria As String, intCounter As Integer)
Dim fso As New FileSystemObject
Dim fldrStartFolder As Folder
Dim subfldrInStart As Folder
Dim subfldrInSubFolder As Folder
Dim subfldrInSubSubFolder As String
Dim strActionLog As String
Set fldrStartFolder = fso.GetFolder(strStartPath)
' Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(fldrStartFolder.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path
If fnCompareCriteriaWithFolderName(fldrStartFolder.Name, strCriteria) Then
' Debug.Print "Found and Opening: " & fldrStartFolder.Name & "Because of: " & strCriteria
Shell "EXPLORER.EXE" & " " & Chr(34) & fldrStartFolder.Path & Chr(34), vbNormalFocus
Else
For Each subfldrInStart In fldrStartFolder.SubFolders
intCounter = intCounter + 1
Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(subfldrInStart.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path
If fnCompareCriteriaWithFolderName(subfldrInStart.Name, strCriteria) Then
' Debug.Print "Found and Opening: " & subfldrInStart.Name & "Because of: " & strCriteria
Shell "EXPLORER.EXE" & " " & Chr(34) & subfldrInStart.Path & Chr(34), vbNormalFocus
Else
Call fnFindFoldersWithCriteria(subfldrInStart, strCriteria, intCounter)
End If
Me.txtProcessed = intCounter
Me.txtProcessed.Requery
Next
End If
Set fldrStartFolder = Nothing
Set subfldrInStart = Nothing
Set subfldrInSubFolder = Nothing
Set fso = Nothing
End Function
Private Function fnCompareCriteriaWithFolderName(strFolderName As String, strCriteria As String) As Boolean
fnCompareCriteriaWithFolderName = False
fnCompareCriteriaWithFolderName = InStr(1, Replace(strFolderName, " ", "", 1, , vbTextCompare), Replace(strCriteria, " ", "", 1, , vbTextCompare), vbTextCompare) > 0
End Function
Private Sub subListFolders(ByVal strFolders As String, intCounter As Integer)
Dim dbs As Database
Dim fso As New FileSystemObject
Dim fldFolders As Folder
Dim fldr As Folder
Dim subfldr As Folder
Dim sfldFolders As String
Dim strSQL As String
Set fldFolders = fso.GetFolder(TrailingSlash(strFolders))
Set dbs = CurrentDb
strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldFolders.Path & Chr(34) & ", " & Chr(34) & fldFolders.Name & Chr(34) & ", '" & fldFolders.Size & "')"
dbs.Execute strSQL
For Each fldr In fldFolders.SubFolders
intCounter = intCounter + 1
strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldr.Path & Chr(34) & ", " & Chr(34) & fldr.Name & Chr(34) & ", '" & fldr.Size & "')"
dbs.Execute strSQL
For Each subfldr In fldr.SubFolders
intCounter = intCounter + 1
sfldFolders = subfldr.Path
Call subListFolders(sfldFolders, intCounter)
Me.sfrmFolderList.Requery
Next
Me.txtListed = intCounter
Me.txtListed.Requery
Next
Set fldFolders = Nothing
Set fldr = Nothing
Set subfldr = Nothing
Set dbs = Nothing
End Sub
Private Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
The form has a subform based on the table, the form has 4 text boxes for the criteria, 2 buttons leading to the click procedures and 1 other text box to store the string for the start folder. There are 2 text boxes that are used to show the number of folders listed and the number processed when searching them for the criteria.
If I had the Rep I would post a picture... :/
I have some other things I wanted to add to this code but haven't had the chance yet. I want to have a way to store the ones that worked in another table or get the user to mark them as good to store.
I can not claim full credit for all the code, I cobbled some of it together from stuff I found all around, even in other posts on stackoverflow.
I really like the idea of posting questions here and then answering them yourself because as the linked article says, it makes it easy to find the answer for later reference.
When I finish the other parts I want to add I will post the code for that too. :)
You can use command prompt to open explorer with path.
here example with batch or command prompt:
start "" explorer.exe (path)
so In VBA ms.access you can write with:
Dim Path
Path="C:\Example"
shell "cmd /c start """" explorer.exe " & Path ,vbHide
Here is what I did.
Dim strPath As String
strPath = "\\server\Instructions\"
Shell "cmd.exe /c start """" """ & strPath & """", vbNormalFocus
Pros:
Avoids opening new explorer instances (only sets focus if window
exists).
Relatively simple (does not need to reference win32 libraries).
Window maximization (or minimization) is not mandatory. Window will open with normal size.
Cons:
The cmd-window is visible for a short time.
This consistently opens a window to the folder if there is none open and switches to the open window if there is one open to that folder.
Thanks to PhilHibbs and AnorZaken for the basis for this. PhilHibbs comment didn't quite work for me, I needed to the command string to have a pair of double quotes before the folder name. And I preferred having a command prompt window appear for a bit rather than be forced to have the Explorer window maximized or minimized.
I may not use shell command because of security in the company so the best way I found on internet.
Sub OpenFileOrFolderOrWebsite()
'Shows how to open files and / or folders and / or websites / or create emails using the FollowHyperlink method
Dim strXLSFile As String, strPDFFile As String, strFolder As String, strWebsite As String
Dim strEmail As String, strSubject As String, strEmailHyperlink As String
strFolder = "C:\Test Files\"
strXLSFile = strFolder & "Test1.xls"
strPDFFile = strFolder & "Test.pdf"
strWebsite = "http://www.blalba.com/"
strEmail = "mailto:YourEmailHere#Website.com"
strSubject = "?subject=Test"
strEmailHyperlink = strEmail & strSubject
'**************FEEL FREE TO COMMENT ANY OF THESE TO TEST JUST ONE ITEM*********
'Open Folder
ActiveWorkbook.FollowHyperlink Address:=strFolder, NewWindow:=True
'Open excel workbook
ActiveWorkbook.FollowHyperlink Address:=strXLSFile, NewWindow:=True
'Open PDF file
ActiveWorkbook.FollowHyperlink Address:=strPDFFile, NewWindow:=True
'Open VBAX
ActiveWorkbook.FollowHyperlink Address:=strWebsite, NewWindow:=True
'Create New Email
ActiveWorkbook.FollowHyperlink Address:=strEmailHyperlink, NewWindow:=True
'******************************************************************************
End Sub
so actually its
strFolder = "C:\Test Files\"
and
ActiveWorkbook.FollowHyperlink Address:=strFolder, NewWindow:=True
Shell "C:\WINDOWS\explorer.exe /select,""" & ActiveWorkbook.Name & "", vbNormalFocus
Here's an answer that gives the switch-or-launch behaviour of Start, without the Command Prompt window. It does have the drawback that it can be fooled by an Explorer window that has a folder of the same name elsewhere opened. I might fix that by diving into the child windows and looking for the actual path, I need to figure out how to navigate that.
Usage (requires "Windows Script Host Object Model" in your project's References):
Dim mShell As wshShell
mDocPath = whatever_path & "\" & lastfoldername
mExplorerPath = mShell.ExpandEnvironmentStrings("%SystemRoot%") & "\Explorer.exe"
If Not SwitchToFolder(lastfoldername) Then
Shell PathName:=mExplorerPath & " """ & mDocPath & """", WindowStyle:=vbNormalFocus
End If
Module:
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function BringWindowToTop Lib "user32" _
(ByVal lngHWnd As Long) As Long
Function SwitchToFolder(pFolder As String) As Boolean
Dim hWnd As Long
Dim mRet As Long
Dim mText As String
Dim mWinClass As String
Dim mWinTitle As String
SwitchToFolder = False
hWnd = FindWindowEx(0, 0&, vbNullString, vbNullString)
While hWnd <> 0 And SwitchToFolder = False
mText = String(100, Chr(0))
mRet = GetClassName(hWnd, mText, 100)
mWinClass = Left(mText, mRet)
If mWinClass = "CabinetWClass" Then
mText = String(100, Chr(0))
mRet = GetWindowText(hWnd, mText, 100)
If mRet > 0 Then
mWinTitle = Left(mText, mRet)
If UCase(mWinTitle) = UCase(pFolder) Or _
UCase(Right(mWinTitle, Len(pFolder) + 1)) = "\" & UCase(pFolder) Then
BringWindowToTop hWnd
SwitchToFolder = True
End If
End If
End If
hWnd = FindWindowEx(0, hWnd, vbNullString, vbNullString)
Wend
End Function
Private Sub Command0_Click()
Application.FollowHyperlink "D:\1Zsnsn\SusuBarokah\20151008 Inventory.mdb"
End Sub
I just used this and it works fine:
System.Diagnostics.Process.Start("C:/Users/Admin/files");
Thanks to many of the answers above and elsewhere, this was my solution to a similar problem to the OP. The problem for me was creating a button in Word that asks the user for a network address, and pulls up the LAN resources in an Explorer window.
Untouched, the code would take you to \\10.1.1.1\Test, so edit as you see fit. I'm just a monkey on a keyboard, here, so all comments and suggestions are welcome.
Private Sub CommandButton1_Click()
Dim ipAddress As Variant
On Error GoTo ErrorHandler
ipAddress = InputBox("Please enter the IP address of the network resource:", "Explore a network resource", "\\10.1.1.1")
If ipAddress <> "" Then
ThisDocument.FollowHyperlink ipAddress & "\Test"
End If
ExitPoint:
Exit Sub
ErrorHandler:
If Err.Number = "4120" Then
GoTo ExitPoint
ElseIf Err.Number = "4198" Then
MsgBox "Destination unavailable"
GoTo ExitPoint
End If
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Resume ExitPoint
End Sub