excel and access integration - excel

I have my front end in excel and backend as access. I send these files to client everyday.i do not want others to see the database. Is there a way to integrate access in excel such that if i transfer only excel file, access file also gets transferred automatically and others do not get to know about my database??
database should remain in access only.

You can't email or FTP an Access file invisibly, but you could move your data to a SQL Server (or other) database that is reachable from the internet.
However that poses several issues:
1) security
2) odbc DSN
3) availability of the odbc driver on the client machine

You can embed the Access database as an object into your Excel file (Insert->Object->Create from file , select Display as icon) and ask the user to extract and remove it. However, this is a bit cumbersome for both sides if you do it manually.
If you want to automate the process, use the following code:
Private Const cStrSheetName As String = "Sheet1"
Private Const cStrObjName As String = "EmbeddedFile"
Sub EmbedFile()
Dim strFile As String
Dim ws As Worksheet
Set ws = Sheets(cStrSheetName)
strFile = Application.GetOpenFilename("Any file (*.*), *.*", 1, _
"Please select a file to embed")
If strFile = "False" Then Exit Sub
On Error Resume Next
ws.Shapes(cStrObjName).Delete
On Error GoTo ErrorHandler
ws.OLEObjects.Add(Filename:=strFile, Link:=False, _
DisplayAsIcon:=True, IconFileName:="", _
IconIndex:=0, IconLabel:=strFile).Select
Selection.Name = cStrObjName
MsgBox "File succesfully embedded!"
Exit Sub
ErrorHandler:
MsgBox "Could not embed file. Error: " & _
Err.Number & " - " & Err.Description
End Sub
Sub ExtractEmbeddedFile()
Dim ws As Worksheet
Set ws = Sheets(cStrSheetName)
On Error Resume Next
ws.OLEObjects(cStrObjName).Copy
If Err.Number Then
MsgBox "No file embedded!"
Exit Sub
End If
On Error GoTo ErrorHandler
CreateObject("Shell.Application").Namespace(ActiveWorkbook.Path) _
.Self.InvokeVerb "Paste"
If MsgBox("File succesfully extracted to " & ActiveWorkbook.Path _
& vbCrLf & vbCrLf & "Do you want to remove the embedded " & _
"file from the this workbook to reduce its size?", vbYesNo) _
= vbYes Then
ws.Shapes(cStrObjName).Delete
End If
Exit Sub
ErrorHandler:
MsgBox "Error extracting file: " & _
Err.Number & " - " & Err.Description
End Sub
This will give you two macros (EmbedFile and ExtractEmbeddedFile) that you can assign to a button in your worksheet.
Please note that you need to modify "Sheet1" in the first line to the name of the worksheet you want to store the embedded file.

Related

Excel VBA Automation error: The object invoked has disconnected from its clients -- inconsistent error

There are a number of issues with this error, but none seem to match my case exactly so posting in the hope of some help.
I have a macro which takes all the files in a directory, opens them silently in a new (hidden) instance of Excel and does two "Save As" operations: one to a location on SharePoint and one to an archive folder. The purpose of this is that the files are produced by SAS in XML format with an XLS extension. Saving them as native XLSX reduces file size dramatically.
Each day we produce a number of files which we then run the macro on. It has been erroring on the same file each day; that is to say it's not exactly the same file, but the same report with different versions each day. It is the largest of the files, but other than that there's nothing outstanding about it.
There are two other oddities:
When running the code step-by-step with F8, the error doesn't occur - this has meant I've been unable to pinpoint exactly where it's erroring;
The code has an option to skip files that error - when skipping and rerunning it again immediately afterwards, with no other changes, the error doesn't occur the second time.
Here's the code; the macro is called different times with different locations as parameters:
Sub LoopThroughDirectory(inPath As String, sharepointPath As String, archivePath As String)
Dim sDir As String
Dim app As New Excel.Application
Dim wb As Excel.Workbook
Dim mbErr As Integer, mbFinished As Integer
If Right(inPath, 1) <> "\" Then inPath = inPath & "\"
On Error GoTo ErrHandler:
sDir = Dir$(inPath, vbNormal)
Do Until Len(sDir) = 0
On Error GoTo LoopError:
app.Visible = False
app.DisplayAlerts = False
Set wb = app.Workbooks.Add(inPath & sDir)
With wb
.SaveAs Filename:=sharepointPath & Left(.Name, InStrRev(.Name, ".")) & "xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, ReadOnlyRecommended:=True
.SaveAs Filename:=archivePath & Left(.Name, InStrRev(.Name, ".")) & "xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
Set wb = Nothing
app.DisplayAlerts = True
app.Quit
Kill (inPath & sDir) ' delete the file
NextFile:
sDir = Dir$ ' find the next filename
Loop
mbFinished = MsgBox( _
"The process has finished. You may need to review any files that have errored.", _
vbOKOnly, _
"Process finished" _
)
On Error GoTo 0
Exit Sub
ErrHandler:
mbErr = MsgBox( _
"There has been an error finding files. Check the SharePoint folder and try again.", _
vbCritical + vbOKOnly, _
"Error finding files" _
)
On Error GoTo 0
Exit Sub
LoopError:
Select Case MsgBox("There has been an error with " & sDir & "." & vbCrLf & vbCrLf & _
"The error is " & vbCrLf & vbCrLf & _
Err.Description & "." & vbCrLf & vbCrLf & _
"Press OK to continue with the next file or Cancel to stop the process.", _
vbCritical + vbOKCancel, "Error")
Case vbOK
Resume NextFile ' go back and try the next file
Case vbCancel
On Error GoTo 0
Exit Sub ' stop processing the files
End Select
End Sub
I suggest to insert the sub below underneath your existing code, outside your procedure but in the same code module.
Private Sub WaitASecond(ByVal Sec As Single)
Dim WaitTill As Single
WaitTill = Timer + Sec
Do
DoEvents
Loop While Timer < WaitTill
End Sub
Call it from your main procedure with a line of code like this.
WaitASecond(0.5) ' which would wait for half a second
Experiment with both the length of time, in increments of 0.25 seconds, if you like, and the location of the code. Bear in mind that it seems that your biggest file creates the problem. So, you might limit the call to that one file or vary the length of the wait depending upon the file size (if it makes a significant difference to your process).
You might instroduce a wait after each SaveAs, only after both SaveAs and/or after the Kill.

Automation Error on "VBProject.VBComponents"- VBA (Excel)

I have this code:
Sub ChangeImportedBOQCodeName(importedName As String)
ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).Name = "BOQ_" & importedName
End Sub
That is called from
Private Sub cmdOK_Click()
Dim TargetName As String
TargetName = cbxSheets.Text
Set TargetSheet = TargetWB.Sheets(TargetName)
TargetSheet.Copy After:=SourceWB.Sheets(SourceSheet.Index)
ChangeImportedBOQCodeName ActiveSheet.CodeName
' Close the User Form
Unload Me
' Inform User on Successful BOQ Import
MsgBox "The selected BOQ was successfully imported to the Analysis", vbInformation, "Import Successful"
' Ask User to generate codes automatically
Dim msgTxt As String
msgTxt = "Generate codes in the imported BOQ, automatically ?" & vbNewLine & vbNewLine & _
"(The proccess may take a while depending on the System specs and BOQ layout and size)"
If MsgBox(msgTxt, vbYesNo, "Auto Code BOQ") = vbYes Then
CheckImportedBOQ ActiveSheet
Else
MsgBox "Auto code genrate was aborted", vbInformation, "Aborted"
End If
End Sub
But I am getting this error:
Run-time error '-2147417848 (80010108)' Automation error The object
invoked has disconnected from its client
And excel exits abruptly.
Problem is that this error never occurred before and the code was working very fine.
I also tried commenting ChangeImportedBOQCodeName ActiveSheet.CodeName this line and the code works.
In your Sub ChangeImportedBOQCodeName you are passing ActiveSheet.CodeName, so all you need to do is change:
ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).Name = "BOQ_" & importedName
To:
ActiveWorkbook.VBProject.VBComponents(importedName).Name = "BOQ_" & importedName

Add user input to Excel table upon upload to Access database

I'm trying to combine user inputs with existing Excel file data so they will all be included in a single table when they are uploaded to the Access database.
Here is the way I have it laid out, but I'm open to changing it however need be.
I'm just completely stuck with what to do next. Upload Date is automatically filled in, but the rest of the parameters will vary based on the product and will have to be filled in manually. I also want it to be mandatory that every field is filled in, so have an error message saying "Enter all parameters" or something like that if they aren't, which wouldn't allow the upload to be completed.
The reason why this is necessary to do in Access and simply not Excel is because the Excel file is generated by AutoCad Electrical and is limited in what data it can include. I tried adding the columns in Excel and importing them and it worked, but my boss said we NEED the user input box to make things easier.
This is the code I have to import the Excel file and add it to the correct table (_MCL UPLOAD). Now I just want to be able to have the user inputs add to this table as extra columns:
Private Sub ImportMCL_Click()
On Error GoTo ErrorHandler
'disable ms access warnings
DoCmd.SetWarnings False
'load spreadsheet
DoCmd.TransferSpreadsheet acImport, 8, "_MCL UPLOAD", selectFile(), True
MsgBox "MCL Imported Successfully!"
're-enable ms access warnings
DoCmd.SetWarnings True
Exit Sub
ErrorHandler:
MsgBox "There was an Error: " & Err & ": " & Error(Err)
End Sub
Function selectFile()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
If .Show Then
selectFile = .SelectedItems(1)
Else
'stop execution if nothing selected
End
End If
End With
Set fd = Nothing
End Function
My final code looks like this:
'Import MCL Files Code
Private Sub ImportMCL_Click()
On Error GoTo ErrorHandler
'disable ms access warnings
DoCmd.SetWarnings False
'load spreadsheet in .xls format
DoCmd.TransferSpreadsheet acImport, 8, "_MCL_UPLOAD", selectFile(), True
DoCmd.OpenQuery "UpdateMCL"
Call InsertInto_MASTER_UPLOAD
Call Delete_MCL_UPLOAD
MsgBox "MCL Imported Successfully!"
're-enable ms access warnings
DoCmd.SetWarnings True
Exit Sub
ErrorHandler:
MsgBox "There was an Error: " & Err & ": " & Error(Err)
End Sub
'Function called in Import MCL Code above
Function selectFile()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
If .Show Then
selectFile = .SelectedItems(1)
Else
'stop execution if nothing selected
End
End If
End With
Set fd = Nothing
End Function
'Function Used to Delete MCL Uploaded file after it's moved to Master Table
Sub Delete_MCL_UPLOAD()
Dim dbs As Database, rst As Recordset
' Modify this line to include the path to Northwind
' on your computer.
Set dbs = OpenDatabase("default_cat.mdb")
' Delete employee records where title is Trainee.
dbs.Execute "DELETE * FROM " _
& "_MCL_UPLOAD "
dbs.Close
End Sub
'Function Appends _MCL UPLOAD into the _MASTER_UPLOAD table
Sub InsertInto_MASTER_UPLOAD()
Dim dbs As Database
' Modify this line to include the path to Northwind
' on your computer.
Set dbs = OpenDatabase("default_cat.mdb")
' Select all records in the New Customers table
' and add them to the Customers table.
dbs.Execute " INSERT INTO _MASTER_UPLOAD " _
& "SELECT * " _
& "FROM [_MCL_UPLOAD];"
dbs.Close
End Sub
I basically created another table to dump all of the combined information into. Thanks for all of your help!

Trouble referencing sheet code names

Here's the basic problem: I am writing an Excel macro and I would like to use the worksheet code names to try to eliminate any errors down the road. I can use the code name for Sheet1 and it works fine, but when I try to use the other codes, like Sheet3 or Sheet7 the editor doesn't recognize them and if I run the macro Excel kicks up an error telling me that my "variable is not defined".
For example:
Option Explicit
Sub Test()
Dim SheetObject As Worksheet
Dim SheetObject2 As Worksheet
Set SheetObject = Sheet1
Set SheetObject2 = Sheet3
MsgBox (SheetObject.Name)
MsgBox (SheetObject2.Name)
End Sub
If I comment out any code referring to SheetObject2 the macro runs correctly. If I put them in I get the errors. I definitely have a Sheet3, and the code name is definitely Sheet3. I've looked around Google all day and can't seem to come up with any solutions, any help would be great.
Thanks in advance,
Jesse
My last employer collected data and created national statistics. Much of that data came in the form of Excel workbooks so I have had a lot of relevant experience.
If you are running your own macro and if this is a one-off exercise then tests like this may be adequate:
Debug.Assert WbookTgt.WsheetTgt.Range("A1").Value = "Date"
Many languages have an Assert statement as a development aid; this is the VBA version. If the assertion is not true, the macro will stop with this statement highlighted.
If this approach is not adequate, you should consider developing parameterised macros that perform checking and updating tasks. I have looked through some of my old macros but most would not be intelligible to someone new to VBA. I have extracted code to create two macros which I hope will give you some ideas.
Macro 1 - OpenWorkbook
Organisations that regularly supply data often use names like: "Xxxxx 1409.xlsx" and "Xxxxx 1410.xlsx" for the September and October versions of their data. You could, for example, update the macro each month for the latest name or you could change the filename to a standard value. Either of these possibilities would be a nuisance and I would be particularly opposed to the second idea because I like to archive all the workbooks I have processed.
OpenWorkbook() uses the Dir statement to search a folder for a file that matches a template such as “Xxxxx*.xls*”. If a single file matches this template, the macro opens the workbook and returns a reference to it.
Macro 2 – CheckWorksheets
You may have noticed that some VBA routines have a fixed number of parameters while others have a variable number of parameters. For example, the following are all valid calls of CheckWorksheets:
If CheckWorksheets(WbookTgt, WbookThis, “Name1”) then
If CheckWorksheets(WbookTgt, WbookThis, “Name1”, “Name2”) then
If CheckWorksheets(WbookTgt, WbookThis, “Name1”, “Name2”, “Name3”) then
CheckWorksheets has three parameters. The first two are workbook references. The third is ParamArray SheetName() As Variant. Any parameter after the first two is placed in array SheetName which can be as large as necessary. Here all the trailing parameters are strings but they could be of any type.
I can use OpenWorkbook to open this month’s version of the source file and then use CheckWorksheets to confirm all the worksheets required by my macro are present.
Worksheet Errors”
These two macros require a worksheet Errors be present in a specified workbook. If the macros detect an error, they add a detailed error message to this worksheet. I have found this a convenient technique for capturing the details of any errors.
Macros Demo1 and Demo2
I have included two macros that demonstrate the use of these macros with workbooks on my system. If you amend Demo1 and Demo2 to operate on some of your workbooks, you should get an idea of what OpenWorkbook and CheckWorksheets can do for you.
Come back with questions as necessary but the more you can decipher OpenWorkbook and CheckWorksheets yourself, the faster you will develop your own skills
Option Explicit
Sub Demo1()
Dim Path As String
Dim WbookThis As Workbook
Dim WbookTgt As Workbook
' Application.ThisWorkbook identifies the workbook containing this macro.
Set WbookThis = Application.ThisWorkbook
' I find it convenient to place my target workbooks in the folder
' holding the workbook containing the macro(s).
Path = WbookThis.Path
Set WbookTgt = OpenWorkbook(Path, "Combined*.xls*", WbookThis)
If WbookTgt Is Nothing Then
' Detailed error message already recorded in "Errors"
Call MsgBox("Wokbook failed checks", vbOKOnly)
Else
With WbookTgt
Debug.Print .Path & "\" & .Name & " opened."
.Close SaveChanges:=False
End With
End If
End Sub
Sub Demo2()
Dim Path As String
Dim WbookThis As Workbook
Dim WbookTgt As Workbook
' Application.ThisWorkbook identifies the workbook containing this macro.
Set WbookThis = Application.ThisWorkbook
' I find it convenient to place my target workbooks in the folder
' holding the workbook containing the macro(s).
Path = WbookThis.Path
Set WbookTgt = OpenWorkbook(Path, "Combined 2.04.xls*", WbookThis)
If WbookTgt Is Nothing Then
' Detailed error message already recorded in "Errors"
Call MsgBox("Wokbook failed checks", vbOKOnly)
Exit Sub
End If
With WbookTgt
If Not CheckWorksheets(WbookTgt, WbookThis, "Critical Path", "Dyn Dims") Then
Call MsgBox("Wokbook failed checks", vbOKOnly)
.Close SaveChanges:=False
Exit Sub
End If
Debug.Print .Path & "\" & .Name & " contains worksheets Critical and Dym Dims"
.Close SaveChanges:=False
End With
End Sub
Function CheckWorksheets(ByRef WbookTgt As Workbook, ByRef WbookError As Workbook, _
ParamArray SheetName() As Variant) As Boolean
' * Return True if WbookTgt contains every specified worksheet.
' * WbookTgt is the workbook to be checked
' * WbookError identifies the workbook containing worksheet "Error" to which any
' error message will be added.
' * SheetName() is an array of worksheet names.
Dim ErrorMsg As String
Dim FoundError As Boolean
Dim FoundSheet() As Boolean
Dim FoundSheetsCount As Long
Dim InxName As Long
Dim InxWsheet As Long
Dim NotFoundSheetsCount As Long
Dim RowErrorNext As Long
Dim SheetNamesFound As String
' Size FoundSheet to match SheetName. Array elements initialised to False
ReDim FoundSheet(LBound(SheetName) To UBound(SheetName))
FoundSheetsCount = 0
NotFoundSheetsCount = 0
With WbookTgt
For InxName = LBound(SheetName) To UBound(SheetName)
NotFoundSheetsCount = NotFoundSheetsCount + 1 ' Assume not found until found
For InxWsheet = 1 To .Worksheets.Count
If SheetName(InxName) = .Worksheets(InxWsheet).Name Then
FoundSheet(InxName) = True
FoundSheetsCount = FoundSheetsCount + 1
NotFoundSheetsCount = NotFoundSheetsCount - 1
Exit For
End If
Next
Next
End With
If NotFoundSheetsCount = 0 Then
CheckWorksheets = True
Exit Function
End If
SheetNamesFound = ""
ErrorMsg = WbookTgt.Path & "\" & WbookTgt.Name & " does not contain "
If NotFoundSheetsCount = 1 Then
ErrorMsg = ErrorMsg & "this expected worksheet:"
Else
ErrorMsg = ErrorMsg & "these expected worksheets:"
End If
For InxName = LBound(SheetName) To UBound(SheetName)
If Not FoundSheet(InxName) Then
ErrorMsg = ErrorMsg & vbLf & " " & SheetName(InxName)
Else
SheetNamesFound = SheetNamesFound & vbLf & " " & SheetName(InxName)
End If
Next
If FoundSheetsCount = 0 Then
' No need to add list of found sheet names
Else
ErrorMsg = ErrorMsg & vbLf & "but does contain "
If FoundSheetsCount = 1 Then
ErrorMsg = ErrorMsg & "this expected worksheet:"
Else
ErrorMsg = ErrorMsg & "these expected worksheets:"
End If
ErrorMsg = ErrorMsg & SheetNamesFound
End If
With WbookError
With .Worksheets("Errors")
RowErrorNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
With .Cells(RowErrorNext, "A")
.Value = Now()
.VerticalAlignment = xlTop
End With
.Cells(RowErrorNext, "B").Value = ErrorMsg
End With
End With
CheckWorksheets = False
End Function
Function OpenWorkbook(ByVal Path As String, ByVal FileTemplate As String, _
ByRef WbookError As Workbook) As Workbook
' * If Path & FileTemplate identifies a single workbook, open it and return
' it as an object. If Path & FileTemplate does not represent a single
' workbook, report the problem in worksheet Errors and return Nothing.
' * WbookError identifies the workbook containing worksheet "Error".
' * Path must be the name of the folder in which the required workbook is located
' * FileTemplate can either be a specific filename or can contain wild cards
' providing only one file matches the template.
' * WbookError identifies the workbook containing worksheet "Error" to which any
' error message will be added.
Dim ErrorMsg As String
Dim FileNameCrnt As String
Dim FileNameMatch As String
Dim RowErrorNext As Long
FileNameMatch = Dir$(Path & "\" & FileTemplate, vbNormal)
If FileNameMatch = "" Then
' No matches found
ErrorMsg = "Template " & Path & "\" & FileTemplate & " does not match any file"
Else
' At least one match.
' If only one match, its name is in FileNameMatch
Do While True
FileNameCrnt = Dir$
If FileNameCrnt = "" Then
' No more matches
Exit Do
End If
' A second or subsequent match has been found.
If FileNameMatch <> "" Then
' This is the second match.
' Initialise error message and report name of first match
ErrorMsg = "Template " & Path & "\" & FileTemplate & " matches more than one file:" & _
vbLf & " " & FileNameMatch
FileNameMatch = "" ' No single match
End If
' Add name of current match to error message
ErrorMsg = ErrorMsg & vbLf & " " & FileNameCrnt
Loop
End If
If FileNameMatch = "" Then
' No single match found.
' ErrorMsg contains an appropriate error message
With WbookError
With .Worksheets("Errors")
RowErrorNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
With .Cells(RowErrorNext, "A")
.Value = Now()
.VerticalAlignment = xlTop
End With
.Cells(RowErrorNext, "B").Value = ErrorMsg
Set OpenWorkbook = Nothing
End With
End With
Else
' Single match found
Set OpenWorkbook = Workbooks.Open(Path & "\" & FileNameMatch)
End If
End Function
Response to extra question
VBA has nothing quite as convenient as VB's Try but it does have some error handling under programmer control.
If you use a command such as:
Worksheets("Sheet2").Delete
the user will be asked to confirm the deletion. To avoid this, use:
Application.DisplayAlerts = False
Worksheets("Sheet2").Delete
Application.DisplayAlerts = True
I have seen code with Application.DisplayAlerts = False at the start of a macro which means no alert will be displayed for the user's attention even if the pogrammer was not expecting it. By bracketing the Delete, I ensure only the alert I was expecting is suppressed.
Consider:
Sub OpenFile()
Dim InputFileNum As Long
InputFileNum = FreeFile
Open "Dummy.txt" For Input As InputFileNum
Debug.Print "File successfully opened"
Close InputFileNum
End Sub
The file "Dummy.txt" does not exist so the macro will stop on the Open statement.
You will sometimes see code like this:
Sub OpenFile()
Dim InputFileNum As Long
On Error GoTo ErrorCode
InputFileNum = FreeFile
Open "Dummy.txt" For Input As InputFileNum
Call MsgBox("File successfully opened", vbOKOnly)
Close InputFileNum
Exit Sub
ErrorCode:
Debug.Print "Unexpected error: " & Err.Number & " " & Err.Description
End Sub
Here I have provided a general handler for any error condition that may occur. I do not approve although I accept that this is slightly better than having the non-technical user seeing the faulty statement highlighted. The trouble is any error will result in the same unhelpful error message.
I never include error handling during development. If an error occurs, I want the macro to stop on the faulty statement so I can consider how to avoid the error. Here I should check the file exists before attempting to open it. I prefer something like this:
Sub OpenFile()
Dim FileSysObj As Object
Dim InputFileNum As Long
On Error GoTo ErrorCode
Set FileSysObj = CreateObject("Scripting.FileSystemObject")
If Not FileSysObj.FileExists("Dummy.txt") Then
Call MsgBox("I am unable to find ""Dummy.txt"". List of helpful suggestions.", vbOKOnly)
Exit Sub
End If
InputFileNum = FreeFile
Open "Dummy.txt" For Input As InputFileNum
Call MsgBox("File successfully opened", vbOKOnly)
Close InputFileNum
Exit Sub
ErrorCode:
Debug.Print "Unexpected error: " & Err.Number & " " & Err.Description
End Sub
I have including checking code for the error I expect. If the file does not exist, I have displayed a message which I hope will help the user fix the problem for themselves.
Sometimes you cannot avoid an error. To test the code below, I created file Dummy.txt but set the "Read access denied" flag. There is no easy method (to my knowledge) for a VBA macro to test this flag. I have a general handler for unexpected errors but I switch it off for the Open statment so I can include specific code for open failures. I have removed the code that uses FileExists() to test if Dummy.txt exists because it is easier to include it with the other open file error tests.
Sub OpenFile()
Dim FileSysObj As Object
Dim InputFileNum As Long
On Error GoTo ErrorCode ' General handler for unexpected errors
InputFileNum = FreeFile
Err.Clear
On Error Resume Next ' Record error in Err object and continue
Open "Dummy.txt" For Input As InputFileNum
Select Case Err.Number
Case 0
' No error.
Case 53 ' File does not exist
Call MsgBox("I am unable to find ""Dummy.txt"". List of helpful suggestions.", vbOKOnly)
Exit Sub
Case 75 ' Path/File access error
Call MsgBox("It appears file ""Dummy.txt"" exists but I do not have permission to read it.", vbOKOnly)
Exit Sub
Case Else
Call MsgBox("My attempt to open ""Dummy.txt"" failed with an unexpected error condition" & vbLf & _
" " & Err.Number & " " & Err.Description, vbOKOnly)
Exit Sub
End Select
On Error GoTo ErrorCode ' Restore general handler for unexpected errors
Call MsgBox("File successfully opened", vbOKOnly)
Close InputFileNum
Exit Sub
ErrorCode:
Debug.Print "Unexpected error: " & Err.Number & " " & Err.Description
End Sub
Visit http://support.microsoft.com/kb/146864 for a long list of error codes and more information about error handling.

Writing text from Excel 2007 to a .txt file on a Sharepoint Site causes Run-Time error'76' Path not found

I have this VBA sub in an Excel 2007 project. It records user name, report name, date, and version on a .txt file in a Sharepoint site. Some of my users are getting a Run-Time error'76' Path not found issue.
Here's my code:
Sub logReport(ReportName As String)
Call AppendTxt("//myaviall/teamsites/AviallReportingSolutions/Airplane_Usage_Log/Airplane_ACT.txt", UNameWindows & ";" & ReportName & ";" & Now & ";" & VersionNum)
Dim oFS, TS, FileObj
'Get text stream
'Set oFS = CreateObject("Scripting.FileSystemObject")
'Set FileObj = oFS.GetFile("//myaviall/teamsites/AviallReportingSolutions/Airplane_Usage_Log/Airplane_ACT.txt")
'Set TS = FileObj.OpenAsTextStream(8, -2) 'ForWriting, TristateUseDefault)
' Write to file
'TS.WriteLine UNameWindows & ";" & ReportName & ";" & Now & ";" & VersionNum
'TS.Close
'Set TS = Nothing
'Set FileObj = Nothing
'Set oFS = Nothing
End Sub
Function AppendTxt(sFile As String, sText As String)
On Error GoTo Err_Handler
Dim FileNumber As Integer
FileNumber = FreeFile ' Get unused file number
Open sFile For Append As #FileNumber ' Connect to the file
Print #FileNumber, sText ' Append our string
Close #FileNumber ' Close the file
Exit_Err_Handler:
Exit Function
Err_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: AppendTxt" & vbCrLf & _
"Error Description: " & Err.Description, vbCritical, "An Error has Occured!"
GoTo Exit_Err_Handler
End Function
If there is only one user that is getting the issue the first thing that I would look at it access, as Scott points out.
I run a very similar procedure which writes a line to a csv file from outlook based on the code here
http://www.devhut.net/2011/06/06/vba-append-text-to-a-text-file/
This is probably not your answer but if the access is ok then it couldnt hurt to try another method.
Update
I also include this into my code to test if the file exists
exists = Dir$(sFile) <> fileName
Where fileName = "Airplane_ACT.txt" But I would maybe try this with a msgBox to see what it returns.
Also try try changing your string to Airplane_ACT_test.txt and run the code, this should create a new txt file, if this is the case then the issue may be related to your initial txt file.
Last thing: try with a different path eg: to the user's desktop.

Resources