If Error Display Messagebox

[nathandavies]

Hi all,

I was wondering if someone could help with the following code, if an error occurs during a line of code a message box displays with an error message and the sub is ended.

This is the line of code.


Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?


This is the full code.

Private Function GetPath(strCustomer As String) As String 'Last updated - 18 Aug 2017
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim bPath As Boolean
Dim strPath As String

Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

[SamT]

strRoot is neither declared nor assigned

This is a bump to raise your post in the list.

[nathandavies]

Updated code for reference


''Code complied by Graham Mayor!''

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\Drawings\"

Public Sub Save()
'Last updated - 18 Aug 2017 - Gmayor
Dim olObj As Object
Dim olMsg As MailItem
Dim selCount As Long
Dim j As Long
Dim fPath1 As String, fPath2 As String, fPath3 As String
Dim strPath As String, strSavePath As String

selCount = ActiveExplorer.Selection.Count
If selCount = 0 Then GoTo lbl_Exit

fPath1 = InputBox("Enter the customer folder name in which to save the messages." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")

fPath1 = Replace(fPath1, "\", "")

fPath2 = GetPath(fPath1)

If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If

strPath = fPath2

CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"
CreateFolders strPath & "\Documents" & "\Documents Received"
CreateFolders strPath & "\Documents" & "\Documents Sent"

For j = selCount To 1 Step -1
Set olObj = ActiveExplorer.Selection.Item(j)
If olObj.Class = olMail Then
If InStr(1, olObj.Categories, "Processed") = 0 Then
Set olMsg = olObj


SaveItem olItem:=olMsg, strPath:=strPath, bAttach:=True, bExcel:=False
olObj.Categories = "Processed" 'add this line
olObj.Save 'add this line
End If
End If
DoEvents 'add this line
Next j


lbl_Exit:
Exit Sub
End Sub

Private Function GetPath(strCustomer As String) As String
'Last updated - 18 Aug 2017 - Gmayor
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim bPath As Boolean
Dim strPath As String

Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Private Sub SaveItem(olItem As MailItem, strPath As String, bAttach As Boolean, bExcel As Boolean)
'Last updated - 18 Aug 2017 - Gmayor
Dim fname As String
Dim strSavePath As String

If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Sent\"
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Received\"
End If

fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strSavePath, fname

If olItem.Sender Like "Nathan Davies" Then 'INSERT NAME HERE
If MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes Then
SaveAttachments olItem, strPath & "\Documents\Documents Sent\"
End If
Else
SaveAttachments olItem, strPath & "\Documents\Documents Received\"

'If bExcel = True Then
'CopyToExcel olItem, strPath

End If
lbl_Exit:
Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
strSaveFolder = strSaveFolder & Format(olItem.ReceivedTime, "yyyy-mm-dd") & Chr(92)
CreateFolders strSaveFolder
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
If Not olAttach.FileName Like "image*.*" Then
strFname = olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFolder, strFname, strExt)
olAttach.SaveAsFile strSaveFolder & strFname
'olAttach.Delete 'delete the attachment
End If
Next j
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String

Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Sub CreateFolders(strPath As String)
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
'Debug.Print strPath & strFileName & ".msg"
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function

Private Function FolderExists(fldr As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function

[sushiboy]

Hi, Trying to amend the code to include in the message box details of failed items.

So in the active column, I have some cells indicating "FAILED". in the adjacent columns I have data in Column A and B. How will the below code be amended so it lists the corresponding data in Column A and B when the message box appears??

At the moment it indicates how many failed items in the active column, but I need to add to this and provide details what the failed items are from Column A and B.
Many thanks


Sub Messagebox1() Dim instances As Long instances = WorksheetFunction.CountIf(Columns(ActiveCell.Column), "FAILED") MsgBox "Found " & instances & " Failed Upload(s)", vbInformation, "TITLE"
End sub