Enable all rules from toolbar button?

[soadfan]

Hello there,
i have this issue which is described HERE (a screenshot of a MSO forum's thread)
EDIT: i cant add links, because i'm new user, so: soadfan dot eu slash nolisting slash rules_in_error slash rules_in_error_thread.png

Just for info i've added and 3 sec delay, but no luck:



Public Sub saveAttachtoDiskNL(itm As Outlook.MailItem)
Debug.Print "*** START NL_STT"
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim yearFolder
dateFormat = Format(itm.ReceivedTime, "dd-mm-yyyy_hh-mm-ss-AMPM_")
yearFolder = Format(itm.ReceivedTime, "yyyy-mm")
saveFolder = "D:\TLC\STT_NL\" & yearFolder & "\"
On Error Resume Next
MkDir saveFolder
On Error GoTo 0
For Each objAtt In itm.attachments
Debug.Print "Found: " & objAtt.FileName & " at " & dateFormat
If LCase(Right(objAtt.FileName, 4)) <> ".jpg" And LCase(Right(objAtt.FileName, 4)) <> ".png" Then
Debug.Print "Confirmed as acceptable file type: " & objAtt.FileName & " at " & dateFormat
objAtt.SaveAsFile saveFolder & dateFormat & "STT_NL" & LCase(Right(objAtt.FileName, 4))
Debug.Print "Successful save: " & objAtt.FileName & " at " & dateFormat
Debug.Print "Before wait:"; Now
Call WaitFor(3)
Debug.Print "After wait:"; Now
Set objAtt = Nothing
Debug.Print "Set objAtt = Nothing"
Debug.Print "-------------------------------------------------------------------------------------------"
End If
Next
End Sub


and log:


*** START NL_STT
Found: WORKBOOK_4YX80QR9J004S642E8Q6AYLNX.ZIP at 16-06-2016_06-34-10-AM_
Confirmed as acceptable file type: WORKBOOK_4YX80QR9J004S642E8Q6AYLNX.ZIP at 16-06-2016_06-34-10-AM_
Successful save: WORKBOOK_4YX80QR9J004S642E8Q6AYLNX.ZIP at 16-06-2016_06-34-10-AM_
Before wait:Mon 16 June 06:34:38 AM
After wait:Mon 16 June 06:34:41 AM
Set objAtt = Nothing
-------------------------------------------------------------------------------------------

Now if i can't make it w0rk i want to be able to enable all disabled rules with one click.
Can anyone help with code for this?

P.S. I tried few google results and tried to adapt them to my needs, but also with no luck

Best regards,
Peter

[gmayor]

Somewhere in that other forum thread you referred to, there is a link to another thread where I believe I explained how to extract attachments to file, which would have been easily adapted to use your folder structure. I have reproduced below a modified version of that procedure which encompasses your file and folder naming requirements and will not overwrite existing files. It shouldn't need any delays adding.


Option Explicit

Public Sub saveAttachtoDiskNL(itm As Outlook.MailItem)
'Graham Mayor - http://www.gmayor.com
Debug.Print "*** START NL_STT"
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat As String
Dim yearFolder As String
Dim strFname As String
Dim sNewName As String
Dim strExt As String
Dim j As Long
dateFormat = Format(itm.ReceivedTime, "dd-mm-yyyy_hh-mm-ss-AMPM_")
yearFolder = Format(itm.ReceivedTime, "yyyy-mm")
saveFolder = "D:\TLC\STT_NL\" & yearFolder & "\"

CreateFolders saveFolder

' On Error GoTo CleanUp
If itm.Attachments.Count > 0 Then
For j = itm.Attachments.Count To 1 Step -1
Set objAtt = itm.Attachments(j)
Debug.Print "Found: " & objAtt.FileName & " at " & dateFormat
If Not objAtt.FileName Like "image*.*" Then
Debug.Print "Confirmed as acceptable file type: " & objAtt.FileName & " at " & dateFormat
strFname = objAtt.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
sNewName = FileNameUnique(saveFolder, dateFormat & "STT_NL." & strExt, strExt)
objAtt.SaveAsFile saveFolder & sNewName
Debug.Print "Successful save: " & objAtt.FileName & " at " & dateFormat
End If
Next j
End If
CleanUp:
Set objAtt = Nothing
Set itm = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
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 FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor - http://www.gmayor.com
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 Function FileExists(filespec) As Boolean
'Graham Mayor - http://www.gmayor.com
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[soadfan]

ok, thanks i''ll try it :ipray: