How to open a folder in Windows Explorer from VBA? - ms-access

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

Related

Display Pdf preview in Ms Access Report using pdf file path

I am new in MS Access. I have pdf file location in textbox. I want when access report load then specific pdf file preview in that report (pdf read from file location). How can I achieve it? Please help?
You can display PDF in Report by converting its pages to images and display them. Withwsh.Runyou can extract duringReport_Loadevent, then store the pages paths in a temporary table.
Have Irfanview with PDF-Plugin installed.
In Front-End, create a table namedTmpExtractedPageswith oneShort-Textfield namedPathto store the paths of the extracted pages.
Create a report with Record-Source.
SELECT TmpExtractedPages.Path FROM TmpExtractedPages;
Add a Picture-Control in Detail-Section (no Header/Footer-Section), that fits to the page and bind it toPath
Put the following code inReport_Loadevent
Private Sub Report_Load()
Dim TempPath As String
TempPath = CurrentProject.Path & "\TempPdf"
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(TempPath) Then
fso.DeleteFolder TempPath
End If
fso.CreateFolder TempPath
Dim PdfFile As String
PdfFile = Me.OpenArgs
Const PathToIrfanView As String = "C:\Program Files (x86)\IrfanView\i_view32.exe"
Dim CmdArgs As String
CmdArgs = Chr(34) & PdfFile & Chr(34) & " /extract=(" & Chr(34) & TempPath & Chr(34) & ",jpg) /cmdexit" 'see i_options.txt in IrfanView folder for command line options
Dim ShellCmd As String
ShellCmd = Chr(34) & PathToIrfanView & Chr(34) & " " & CmdArgs
Debug.Print ShellCmd
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
Const WaitOnReturn As Boolean = True
Const WindowStyle As Long = 0
wsh.Run ShellCmd, WindowStyle, WaitOnReturn
With CurrentDb
.Execute "Delete * From TmpExtractedPages", dbFailOnError
Dim f As Object
For Each f In fso.GetFolder(TempPath).Files
.Execute "Insert Into TmpExtractedPages (Path) Values ('" & Replace(f.Path, "'", "''") & "');", dbFailOnError
Next f
End With
Set fso = Nothing
Set wsh = Nothing
End Sub
You provide the path to the PDF to display asOpenArgsargument on open report:
DoCmd.OpenReport "rpt_pdf", acViewPreview, , , , "path\to\pdf"
Keep in mind that adding, then deleting records to the temp table, will bloat your database if you don't compact it later (or just deploy a fresh Front-End copy on start, as I do).
If you just need to display the pdf file, you could create a button next to the textbox and in its on click event:
Private Sub cmdView_Click()
If Nz(Me.txtPdfLocation) <> "" Then
Application.FollowHyperlink Me.txtPdfLocation
End If
End Sub

how i can merge multi pdfs files by using VBA code

I have a table that contains a paths of multi pdfs file...now I need a VBA code to merge all these files to a single pdf file.
Notice:-the number of pdfs files to be merged varies from time to time.
Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
RS.Close
Set RS = Nothing`enter code here`
public Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDFs = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDFs = False
End If
On Error GoTo 0
End Function
This uses a list of PDF or PS files to create one PDF. Sorry it's in VB.net and I don't really have time to convert. But it illustrates the concept if you can wade through it. Basically you write the options and file names to a text file then use that file as an argument to Ghostscript.
Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
ByVal PDFPathName As String, _
ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)
'check that all files exist
PSPathFileList.ForEach(AddressOf CheckFiles)
'check old pdf file
If IO.File.Exists(PDFPathName) Then
Throw New ApplicationException( _
"PDF cannot be created. File already exists: " & PDFPathName)
End If
'convert engine
Dim myProcInfo As New ProcessStartInfo
myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
Debug.Print(myProcInfo.FileName)
'write file names to text file as the list can be very long
Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"
Dim ft As New StreamWriter(fiName2)
ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
For i As Long = 0 To PSPathFileList.Count - 1
ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
Next
ft.Close()
'set args to text file
myProcInfo.Arguments = """#" & fiName2 & """"
'set up for output and errors
myProcInfo.UseShellExecute = False
myProcInfo.RedirectStandardOutput = True
myProcInfo.RedirectStandardError = True
Debug.Print(myProcInfo.Arguments)
'do the conversion
Dim myProc As Process = Process.Start(myProcInfo)
Debug.Print(myProc.StandardOutput.ReadToEnd)
Debug.Print(myProc.StandardError.ReadToEnd)
If WaitForExit Then
'wait for finish; (no more than 60 seconds)
myProc.WaitForExit(60000)
'delete PS
If DeletePS Then
PSPathFileList.ForEach(AddressOf DeleteFiles)
End If
End If
End Sub
Here's VBA code for a single PS to PDF. So between the VB.net above and this below hopefully you can salvage something useful.
Private Sub printToPdfDemo()
'verify printer setup
'be sure to install the PsPrinterInstall module
Call PSPrinterSetup
Dim svPsFileName As String
Dim svPDFName As String
'define names
svPsFileName = "C:\Temp\Input 1.ps"
svPDFName = "C:\Temp\Output 1.PDF"
'save current printer
Dim PrinterInUse As String
PrinterInUse = Application.ActivePrinter
'print to PS
'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
PrToFileName:=svPsFileName
'revert to saved printer name
Application.ActivePrinter = PrinterInUse
'convert
Call ConvertToPDF(svPsFileName, svPDFName)
End Sub
Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
Dim fso As New FileSystemObject
'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim folGS As Folder
Dim lcCmd As String
'check inputs
If svPsFileName = "" Or svPDFName = "" Then
Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
Exit Sub
End If
'check file
If Not fso.FileExists(svPsFileName) Then
Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
Exit Sub
End If
'check variable
If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation
'delete old file
If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)
'get files
Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE
'GS command
lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
"-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
"-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
"-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
& " -dBATCH " & """" & svPsFileName & """"
'convert
Debug.Print lcCmd
Call ShellWait(lcCmd)
'delete PS
If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)
End Sub

Force a zip to open unzip to specific location

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.

VBA script to close every instance of Excel except itself

I have a subroutine in my errorhandling function that attempts to close every workbook open in every instance of Excel. Otherwise, it might stay in memory and break my next vbscript. It should also close every workbook without saving any changes.
Sub CloseAllExcel()
On Error Resume Next
Dim ObjXL As Excel.Application
Set ObjXL = GetObject(, "Excel.Application")
If Not (ObjXL Is Nothing) Then
Debug.Print "Closing XL"
ObjXL.Application.DisplayAlerts = False
ObjXL.Workbooks.Close
ObjXL.Quit
Set ObjXL = Nothing
Else
Debug.Print "XL not open"
End If
End Sub
This code isn't optimal, however. For example, it can close 2 workbooks in one instance of Excel, but if you open 2 instances of excel, it will only close out 1.
How can I rewrite this to close all Excel without saving any changes?
Extra Credit:
How to do this for Access as well without closing the Access file that is hosting this script?
You should be able to use window handles for this.
Public Sub CloseAllOtherAccess()
Dim objAccess As Object
Dim lngMyHandle As Long
Dim strMsg As String
On Error GoTo ErrorHandler
lngMyHandle = Application.hWndAccessApp
Set objAccess = GetObject(, "Access.Application")
Do While TypeName(objAccess) = "Application"
If objAccess.hWndAccessApp <> lngMyHandle Then
Debug.Print "found another Access instance: " & _
objAccess.hWndAccessApp
objAccess.Quit acQuitSaveNone
Else
Debug.Print "found myself"
Exit Do
End If
Set objAccess = GetObject(, "Access.Application")
Loop
ExitHere:
Set objAccess = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure CloseAllOtherAccess"
MsgBox strMsg
GoTo ExitHere
End Sub
It appears to me GetObject returns the "oldest" Access instance. So that sub closes all Access instances started before the one which is running the sub. Once it finds itself, it stops. Maybe that's fine for your situation. But if you need to also close Access instances started after the one which is running the code, look to Windows API window handle functions.
I didn't try this approach for Excel. But I did see Excel provides Application.Hwnd and Application.Hinstance ... so I suspect you can do something similar there.
Also, notice I got rid of On Error Resume Next. GetObject will always return an Application object in this sub, so it didn't serve any purpose. Additionally, I try to avoid On Error Resume Next in general.
Update: Since GetObject won't do the job for you, use a different method to get the window handles of all the Access instances. Close each of them whose window handle doesn't match the one you want to leave running (Application.hWndAccessApp).
Public Sub CloseAllAccessExceptMe()
'FindWindowLike from: '
'How To Get a Window Handle Without Specifying an Exact Title '
'http://support.microsoft.com/kb/147659 '
'ProcessTerminate from: '
'Kill a Process through VB by its PID '
'http://en.allexperts.com/q/Visual-Basic-1048/Kill-Process-VB-its-1.htm '
Dim lngMyHandle As Long
Dim i As Long
Dim hWnds() As Long
lngMyHandle = Application.hWndAccessApp
' get array of window handles for all Access top level windows '
FindWindowLike hWnds(), 0, "*", "OMain", Null
For i = 1 To UBound(hWnds())
If hWnds(i) = lngMyHandle Then
Debug.Print hWnds(i) & " -> leave myself running"
Else
Debug.Print hWnds(i) & " -> close this one"
ProcessTerminate , hWnds(i)
End If
Next i
End Sub
Differentiating open instances of an application is a very old problem, and it is not unique to VBA.
I've tried to figure this out myself over the years, never with greater success than the time before.
I think the long and short of it is that you can never know if the application instance you're referencing is the one in which the code is executing (so terminating it might leave other instances open).
I just tried the following with both Excel and Access :
Dim sKill As String
sKill = "TASKKILL /F /IM msaccess.exe"
Shell sKill, vbHide
If you change the msaccess.exe to excel.exe, excel will be killed.
If you want a bit more control over the process, check out:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=811
I know this is an old post but for those who visit here from searches may find it helpful.
This code was found and modified. It will give you every SHEET in every WORKBOOK in every INSTANCE. From there you can determine the active instance.
Module..............
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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Code…………………...
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0
Sub ListAll()
Dim I As Integer
Dim hWndMain As Long
On Error GoTo MyErrorHandler
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
I = 1
Do While hWndMain <> 0
Debug.Print "Excel Instance " & I
GetWbkWindows hWndMain
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
I = I + 1
Loop
Exit Sub
MyErrorHandler:
MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Sub GetWbkWindows(ByVal hWndMain As Long)
Dim hWndDesk As Long
Dim hWnd As Long
Dim strText As String
Dim lngRet As Long
On Error GoTo MyErrorHandler
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Do While hWnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
If Left$(strText, lngRet) = "EXCEL7" Then
GetExcelObjectFromHwnd hWnd
Exit Sub
End If
hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Sub
MyErrorHandler:
MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
Dim fOk As Boolean
Dim I As Integer
Dim obj As Object
Dim iid As UUID
Dim objApp As Excel.Application
Dim myWorksheet As Worksheet
On Error GoTo MyErrorHandler
fOk = False
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Set objApp = obj.Application
For I = 1 To objApp.Workbooks.Count
Debug.Print " " & objApp.Workbooks(I).Name
For Each myWorksheet In objApp.Workbooks(I).Worksheets
Debug.Print " " & myWorksheet.Name
DoEvents
Next
fOk = True
Next I
End If
GetExcelObjectFromHwnd = fOk
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
I hope this helps someone :)
This is a response to an old post, but same as the poster in 2012, hopefully it helps someone who may come here based on a generic web search.
Background
My company uses XLSX "models" to turn our data into "pretty" automatically. The data exports from SAS as XLS; we do not have the licensing or add-ons to export as XLSX. The normal process is to copy/paste each of the 14 SAS outputs into the XLSX. The code below iterates through the first two exports where data is copied from the XLS, pasted into the XLSX, and the XLS closed.
Please note: The XLSX file is saved to the hard drive. The XLS files are NOT SAVED, i.e. the path goes to "My Documents/" but there is no file name or file visible there.
Sub Get_data_from_XLS_to_XLSX ()
Dim xlApp1 As Excel.Application
Dim xlApp2 As Excel.Application
'Speed up processing by turning off Automatic Calculations and Screen Updating
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Copies data from Book1 (xls) and pastes into ThisWorkbook (xlsx), then closes xls file
Set xlApp1 = GetObject("Book1").Application
xlApp1.Workbooks("Book1").Sheets("Sheet1").Range("A2:E2").Copy
Application.ThisWorkbook.Worksheets("Data1").Cells(5, 2).PasteSpecialPaste:=xlPasteValues
'Clears the clipboard, turns off the "do you want to save" alert, closes xls file
xlApp1.CutCopyMode = False
xlApp1.DisplayAlerts = False
xlApp1.Quit
xlApp1.DisplayAlerts = True
'Same as the first one above, but now it's a second/different xls file, i.e. Book2
Set xlApp2 = GetObject("Book2").Application
xlApp2.Workbooks("Book2").Sheets("Sheet1").Range("A2:E2").Copy
Application.ThisWorkbook.Sheets("Data2").Cells(10, 2).PasteSpecial Paste:=xlPasteValues
'Clears the clipboard, turns off the "do you want to save" alert, closes xls file
xlApp2.CutCopyMode = False
xlApp2.DisplayAlerts = False
xlApp2.Quit
xlApp2.DisplayAlerts = True
'Sub continues for 12 more iterations of similar code
End Sub
You need to be explicit in qualifying your statements. i.e. instead of Workbooks("Book_Name") make sure you identify the application you are referring to, be it Application.Workbooks("Book_Name") or xlApp1.Workbooks("Book_Name")
try putting it in a loop
Set ObjXL = GetObject(, "Excel.Application")
do until ObjXL Is Nothing
Debug.Print "Closing XL"
ObjXL.Application.DisplayAlerts = False
ObjXL.Workbooks.Close
ObjXL.Quit
Set ObjXL = Nothing
Set ObjXL = GetObject(, "Excel.Application") ' important!
loop

exporting code from Microsoft Access

Is there any way to bulk-export Microsoft Access code to files? I see I can export one file at a time, but there are hundreds and I'll be here all day. It there no "Export All" or multi-select export anywhere?
You can do this without having to write any code at all. From the menu, choose tools->analyze->database documenter.
This will give you a bunch of options to print out the code. You can then while viewing the report ether send it out to your PDF printer (if you have one). Or, simply print out to a text file printer. Or you can even then click on the word option in the report menu bar and the results will be sent out to word
The database documenter has provisions to print out all code, including code in forms.
So, in place of some of the suggested code examples you can do this without having to write any code at all. Do play with the additional options in the documenter. The documenter will produce HUGE volumes print out information for every single property and object in the database. So, if you don't un-check some of the options then you will easily empty a full size printer tray of paper. This documenter thus results in huge printouts.
To output all code to desktop, including code from forms and reports, you can paste this into a standard module and run it by pressing F5 or step through with F8. You may wish to fill in the name of the desktop folder first.
Sub AllCodeToDesktop()
''The reference for the FileSystemObject Object is Windows Script Host Object Model
''but it not necessary to add the reference for this procedure.
Dim fs As Object
Dim f As Object
Dim strMod As String
Dim mdl As Object
Dim i As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
''Set up the file.
''SpFolder is a small function, but it would be better to fill in a
''path name instead of SpFolder(Desktop), eg "c:\users\somename\desktop"
Set f = fs.CreateTextFile(SpFolder(Desktop) & "\" _
& Replace(CurrentProject.Name, ".", "") & ".txt")
''For each component in the project ...
For Each mdl In VBE.ActiveVBProject.VBComponents
''using the count of lines ...
i = VBE.ActiveVBProject.VBComponents(mdl.Name).CodeModule.CountOfLines
''put the code in a string ...
If i > 0 Then
strMod = VBE.ActiveVBProject.VBComponents(mdl.Name).codemodule.Lines(1, i)
End If
''and then write it to a file, first marking the start with
''some equal signs and the component name.
f.writeline String(15, "=") & vbCrLf & mdl.Name _
& vbCrLf & String(15, "=") & vbCrLf & strMod
Next
''Close eveything
f.Close
Set fs = Nothing
End Sub
To get special folders, you can use the list supplied by Microsoft.
Enumerating Special Folders: http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_higv.mspx?mfr=true
From: http://wiki.lessthandot.com/index.php/Code_and_Code_Windows
There is nothing in the interface to export more than one module at a time.
You can code your own "export all" equivalent easily:
Public Sub ExportModules()
Const cstrExtension As String = ".bas"
Dim objModule As Object
Dim strFolder As String
Dim strDestination As String
strFolder = CurrentProject.Path
For Each objModule In CurrentProject.AllModules
strDestination = strFolder & Chr(92) & objModule.Name & cstrExtension
Application.SaveAsText acModule, objModule.Name, strDestination
Next objModule
End Sub
Here's my version:
'============================================================'
' OutputCodeModules for Access
' Don Jewett, verion 2014.11.10
' Exports the following items from an Access database
' Modules
' Form Modules
' Report Modules
'
' Must be imported into Access database and run from there
'============================================================'
Option Explicit
Option Compare Database
Private Const KEY_MODULES As String = "Modules"
Private Const KEY_FORMS As String = "Forms"
Private Const KEY_REPORTS As String = "Reports"
Private m_bCancel As Boolean
Private m_sLogPath As String
'------------------------------------------------------------'
' >>>>>> Run this using F5 or F8 <<<<<<<<
'------------------------------------------------------------'
Public Sub OutputModuleHelper()
OutputModules
End Sub
Public Sub OutputModules(Optional ByVal sFolder As String)
Dim nCount As Long
Dim nSuccessful As Long
Dim sLine As String
Dim sMessage As String
Dim sFile As String
If sFolder = "" Then
sFolder = Left$(CurrentDb.Name, InStrRev(CurrentDb.Name, "\") - 1)
sFolder = InputBox("Enter folder for files", "Output Code", sFolder)
If sFolder = "" Then
Exit Sub
End If
End If
'normalize root path by removing trailing back-slash
If Right(sFolder, 1) = "\" Then
sFolder = Left(sFolder, Len(sFolder) - 1)
End If
'make sure this folder exists
If Not isDir(sFolder) Then
MsgBox "Folder does not exist", vbExclamation Or vbOKOnly
Exit Sub
End If
'get a new log filename
m_sLogPath = sFolder & "\_log-" & Format(Date, "yyyy-MM-dd-nn-mm-ss") & ".txt"
sLine = CurrentDb.Name
writeLog sLine
sMessage = sLine & vbCrLf
sLine = Format(Now, "yyyy-MM-dd nn:mm:ss") & vbCrLf
writeLog sLine
sMessage = sMessage & sLine & vbCrLf
'output modules
nCount = CurrentDb.Containers(KEY_MODULES).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_MODULES)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & KEY_MODULES & " exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
'output form modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_FORMS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_FORMS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Form Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
'output report modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_REPORTS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_REPORTS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Report Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
If Len(sMessage) Then
MsgBox sMessage, vbInformation Or vbOKOnly, "OutputModules"
End If
End Sub
Private Function outputContainerModules( _
ByVal sFolder As String, _
ByVal sKey As String) As Long
Dim n As Long
Dim nCount As Long
Dim sName As String
Dim sPath As String
On Error GoTo EH
'refactored this to use reference to Documents,
'but the object reference doesn't stick around
'and I had to roll back to this which isn't as pretty.
'but this works (and if it ain't broke...)
For n = 0 To CurrentDb.Containers(sKey).Documents.Count - 1
nCount = nCount + 1
sName = CurrentDb.Containers(sKey).Documents(n).Name
Select Case sKey
Case KEY_FORMS
sName = "Form_" & sName
Case KEY_REPORTS
sName = "Report_" & sName
End Select
sPath = sFolder & "\" & sName & ".txt"
DoCmd.OutputTo acOutputModule, sName, acFormatTXT, sPath, False
Next 'n
outputContainerModules = nCount
Exit Function
EH:
nCount = nCount - 1
Select Case Err.Number
Case 2289 'can't output the module in the requested format.
'TODO: research - I think this happens when a Form/Report doesn't have a module
Resume Next
Case Else
Dim sMessage As String
writeError Err, sKey, sName, nCount
sMessage = "An Error ocurred outputting " & sKey & ": " & sName & vbCrLf & vbCrLf _
& "Number " & Err.Number & vbCrLf _
& "Description:" & Err.Description & vbCrLf & vbCrLf _
& "Click [Yes] to continue with export or [No] to stop."
If vbYes = MsgBox(sMessage, vbQuestion Or vbYesNo Or vbDefaultButton2, "Error") Then
Resume Next
Else
m_bCancel = True
outputContainerModules = nCount
End If
End Select
End Function
Private Function writeFile( _
ByVal sPath As String, _
ByRef sMessage As String, _
Optional ByVal bAppend As Boolean) As Boolean
'Dim oFSO as Object
'Dim oStream as Object
'Const ForWriting As Long = 2
'Const ForAppending As Long = 8
'Dim eFlags As Long
Dim oFSO As FileSystemObject
Dim oStream As TextStream
Dim eFlags As IOMode
On Error GoTo EH
'Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oFSO = New FileSystemObject
If bAppend Then
eFlags = ForAppending
Else
eFlags = ForWriting
End If
Set oStream = oFSO.OpenTextFile(sPath, eFlags, True)
oStream.WriteLine sMessage
writeFile = True
GoTo CLEAN
EH:
writeFile = False
CLEAN:
If Not oFSO Is Nothing Then
Set oFSO = Nothing
End If
If Not oStream Is Nothing Then
Set oStream = Nothing
End If
End Function
Private Sub writeError( _
ByRef oErr As ErrObject, _
ByVal sType As String, _
ByVal sName As String, _
ByVal nCount As Long)
Dim sMessage As String
sMessage = "An Error ocurred outputting " & sType & ": " & sName & " (" & nCount & ")" & vbCrLf _
& "Number " & oErr.Number & vbCrLf _
& "Description:" & oErr.Description & vbCrLf & vbCrLf
writeLog sMessage
End Sub
Private Sub writeLog( _
ByRef sMessage As String)
On Error GoTo EH
writeFile m_sLogPath, sMessage & vbCrLf, True
Exit Sub
EH:
'swallow errors?
End Sub
Private Function isDir(ByVal sPath As String) As Boolean
On Error GoTo EH
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If Dir$(sPath & ".", vbDirectory) = "." Then
isDir = True
ElseIf Len(sPath) = 3 Then
If Dir$(sPath, vbVolume) = Left(sPath, 1) Then
isDir = True
End If
End If
Exit Function
EH:
isDir = False
End Function