I completely lost my VBA touch, anyone that can help, I greatly appreciate it.
For outlook desktop I want to a rule that automatically moves item to a folder, marks it as read and calls a script. ( I managed to do that )
How to enable script in outlook 2016: https://www.slipstick.com/outlook/rules/outlooks-rules-and-alerts-run-a-script/
For the subroutine to be seen by Rule Wizard, the argument must by type MailItem.
The script I want to run, is to save the message identified by the rule to disk as a txt file, and for that I am using:
In the module "ThisOutlookSession" the following code ( found it on Outlook VBA macro for saving emails copies in a local folder ) :
Public Sub SaveToDiskScript(Item As Outlook.MailItem)
Const olMsg As Long = 0 '0=Text format (.txt) -> https://learn.microsoft.com/en-us/office/vba/api/outlook.olsaveastype
Dim m As MailItem
Dim savePath As String
Set m = Item
savePath = "C:\Users\im.a.pretty.user\Desktop\StorageFolder\"
savePath = savePath & m.Subject & Format(Now(), "yyyy-mm-dd-hhNNss")
savePath = savePath & ".txt"
m.SaveAs savePath, olMsg
End Sub
Thank you
The file path passed to the SaveAs method of the MailItem class is built based on the Subject line which may contain forbidden symbols:
savePath = "C:\Users\im.a.pretty.user\Desktop\StorageFolder\"
savePath = savePath & m.Subject & Format(Now(), "yyyy-mm-dd-hhNNss")
savePath = savePath & ".txt"
I'd recommend checking whether it contains any forbidden symbols before, see What characters are forbidden in Windows and Linux directory names? for more information.
Also you may try to specify a different folder without dots in the file path.
Related
I have a situation that is really flummoxing me. Simple code I've used for years is failing in the weirdest way. I have a feeling the cause is related to either anti-virus junk or GPO, but, even those, I have seen them operate before on this scenario--but nothing like how I am seeing it now.
Note - this code has been working perfectly for several people, until one end-user got a new Surface laptop from I.T., purportedly for better compatibility with Teams and 365. ALL users (working, non-working) are on Windows 10.
Scenario:
I'm using Scripting.Filesystemobject
setting an object variable (Textstream intent), as fso.createtextfile
The filepath (name) I am creating is actually filename.vbs...At the moment this line executes, I can see the vbs file successfully in the folder
I use Textstream.Write to put some content in the file
I then use Textstream.Close (normally at this point you get a solid, stable, useable file). Immediately upon execution of the last line, Textstream.Close, the file DISAPPEARS from the folder-GONE.
The folder I'm writing to is the same as Start > Run > %appdata%
I've also tried this in Documents folder (Environ$("USERPROFILE") & "\My Documents") and get the exact same result
I've seen group policies and AV stuff that will prevent VBS from running, but that isn't my case--I've tested with this user, and she has no problem:
Creating a txt file in either of those folders
Manually creating a .vbs file in either of those folders
Even RUNNING the resulting vbs file in either folder
But somehow when I programmatically create .VBS in code, the second I close the textstream, the file is gone from the folder.
Any insight? The internet searches I did were void of all information on this scenario!! It would take me 2 weeks to open a ticket and get any help from I.T.
This is Excel VBA, but I highly doubt the problem has anything to do with Excel nor VBA...this is standard usage of windows scripting.filesystemobject:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'initiate full backup vbs script:
Dim ts As Object, fso As Object, strScriptText As String, strScriptPath As String
'populate our variable with the full text of the script: found on QLoader in this range:
strScriptText = ThisWorkbook.Worksheets("QLoader").Range("z_BackupScriptText").Value
'replace the text "placeholder" with this workbook's actual full path/name:
strScriptText = Replace(strScriptText, "placeholder", ThisWorkbook.FullName)
'fire up FSO:
Set fso = CreateObject("scripting.filesystemobject")
'determine the new VBS file's path
strScriptPath = Environ("AppData") & "\Backup_" & Format(Now, "yymmddhhmmss") & ".vbs"
'create our textstream object:
Set ts = fso.createtextfile(strScriptPath)
'write our script into it
ts.write strScriptText
'save and close it
ts.Close 'RIGHT HERE THE FILE DISAPPEARS FROM THE FOLDER ***********
'GO:
Shell "wscript " & strScriptPath, vbNormalFocus
End Sub
It does look like an antivirus thing...
If the issue is just the vbs extension though, you can use something like this:
Sub tester()
Dim ts As Object, fso As Object, strScriptText As String, strScriptPath As String
Set fso = CreateObject("scripting.filesystemobject")
strScriptPath = Environ("AppData") & "\Backup_" & Format(Now, "yymmddhhmmss") & ".txt"
Set ts = fso.createtextfile(strScriptPath)
ts.write "Msgbox ""Hello"""
ts.Close
'need to specify the script engine to use
Shell "wscript.exe /E:vbscript """ & strScriptPath & """ ", vbNormalFocus
End Sub
I receive 4 weekly emails from 3 different senders.
Emails 1 and 2 are from the same sender and can be recognized through VBA. These emails contain zip files, where each zip file has one .csv file.
Emails 3 and 4 can also be recognized by VBA and the attachments are Excel sheets (.xlsx).
I want to extract and unzip (where needed) and save these 4 files in a folder as; email1.report, email2.report etc.
Then make a copy of these 4 files in a different folder for each file and rename like; "Today's date".email1.report.csv etc.
I want to combine these steps in a single code and to replace the email1.report, email2.report etc., files without a prompt asking "do you want to replace the files? Yes, No?"
Is it possible to detect the new weekly emails and do this automatically?
The code I use to unzip and save:
Else
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "zip" Then
FileNameFolder = "C:\Users\..."
FileName = FileNameFolder & Left(Atmt.FileName, (InStr(1, Atmt.FileName, ".zip") - 1)) & ".txt"
Atmt.SaveAsFile FileName
FileNameT = FileNameFolder & Atmt.FileName
Name FileName As FileNameT
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileNameT)).Items
Kill FileNameT
i = i + 1
End If
Next Atmt
'item.Close
End If
I won't develop the code for your specific problem, but I recently wrote something similar. Maybe you can go from here by altering to your criteria etc.
In my case I had two e-mails incoming shortly after another, within 60 seconds. Both mails had "FP" in their subject and a .pdf-attachment. The task was to concatenate these attachments using the installed PDF24, which luckily offers a shell command for this.
This was the code, placed in the "ThisOutlookSession" of the Outlook VBA project explorer.
Public btAttachmentMails As Byte
Public dtArrivalStamp As Date
Public strPathFirstMailAttachment As String
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Dim i As Integer
Dim strDocumentsFolder As String
strDocumentsFolder = CreateObject("WScript.Shell").SpecialFolders(16)
strPathFirstMailAttachment = strDocumentsFolder & "\attachment_mail1.pdf"
If Item.Subject Like "FP*" Then
If btAttachmentMails = 0 Then
'first mail -> save attachment and set counter to 1
btAttachmentMails = 1
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment
End If
Next i
ElseIf btAttachmentMails = 1 Then
Dim dtNow As Date: dtNow = Time
If TimeDiff(dtArrivalStamp, dtNow) <= 60 Then
'second mail within 60 seconds with subject containing "FP" -> save attachment and concatenate both via pdf24, then delete both files
'save attachment of second mail
Dim strPathSecondMailAttachment As String
strPathSecondMailAttachment = strDocumentsFolder & "\attachment_mail2.pdf"
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathSecondMailAttachment
End If
Next i
'concatenate pdf documents via pdf24 shell
Dim strOutputPath As String
strOutputPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Year(Date) & Month(Date) & Day(Date) & "_Wartungsplan_" & Replace(CStr(Time), ":", "-") & ".PDF"
Shell ("""C:\Program Files (x86)\PDF24\pdf24-DocTool.exe"" -join -profile ""default/good"" -outputFile " & strOutputPath & " " & strPathFirstMailAttachment & " " & strPathSecondMailAttachment)
'inform user
MsgBox ("Files have been successfully concatenated. You can find the combined file on your desktop.")
'reset status, delete temporary documents
btAttachmentMails = 0
If CreateObject("Scripting.FileSystemObject").fileexists(strPathFirstMailAttachment) Then Kill strPathFirstMailAttachment
If CreateObject("Scripting.FileSystemObject").fileexists(strPathSecondMailAttachment) Then Kill strPathSecondMailAttachment
Else
'second mail did not arrive within 60 seconds -> treat as first mail
'save new arrival time and overwrite old firstMailAttachment with this one
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment 'overwrites existing file
End If
Next i
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & " - please contact XY"
Resume ExitNewItem
End Sub
Function TimeDiff(StartTime As Date, StopTime As Date)
TimeDiff = Abs(StopTime - StartTime) * 86400
End Function
cr44sh has posted an answer while I was creating mine. He has recommended using a new item event while I have recommended using a rule. I prefer rules but you can choose which ever approach you favour.
It is impossible to fully answer your question but I believe I can give enough help for you to construct the macros you need yourself.
You say that these emails can be identified with VBA. That suggests the best approach is an Outlook rule which uses the “run a script” option where “run a script” means “run a macro”. I will discuss the rule later but first you need the macros that will be run.
You will need two macros like this:
Public Sub Type1Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
Public Sub Type2Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
I am sure you can create better names for these macros. I have read that macros to be run by a rule must be in ThisOutlookSession. In my experience, they can be in an ordinary module providing they are declared as Public. I only use ThisOutlookSession for code that has to be in that code area. If code can be in a module, that is where I place it. I suggest creating a new module which will be named Module1 or Module2. Use function key F4 to access its properties and rename it as “ModRuleMacros” or similar. Giving modules meaningful names makes it so much easier to find the code you want to look at today.
Although the aim is to create a macro to be run by a rule, you need a way of testing the macro. If you have some of these emails saved somewhere, you can activate the rule by moving one of those emails to Inbox. However, I generally find it easier to use a macro like this:
Sub TestType1Email()
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call Type1Email(ItemCrnt)
Next
End If
End Sub
To use this macro, you select one or more Type1 emails and then run macro TestType1Email. This macro will pass the selected emails, one at a time, to the macro Type1Email. This will allow you to single step through macro Type1Email and ensure that it works to your entire satisfaction. I find this to be the easier method of testing a new Outlook macro.
It may be helpful to check what a rule can do for you. Select one of these emails and then click on Rules, which is in the middle of the Home tab, and then Create rule …. Selecting one of these emails means the first window is filled out with some options. Click Advanced options …. The new window lists all the options for selecting an email. Are all the options you need to select a type 1 or a type 2 email listed? The list is comprehensive but not complete. For example, you cannot select by the presence of attachments. Identify the options you can use and identify the options you need that are missing. Click Cancel twice to exist from rule creation.
You will need include code for any missing options in your macro.
Your question implies you have all the code you need for processing the emails except for suppressing the replace question. You need to check if there is an existing file before creating the new file. This is the routine that I use to check if a file exists:
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean
' Returns True if file exists. Assumes path already tested.
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
' Ensure only one "\" between path and filename
If Right$(PathName, 1) <> "\" Then
PathName = PathName & "\"
End If
If Left$(FileName, 1) = "\" Then
FileName = Mid$(FileName, 2)
End If
FileExists = False
On Error Resume Next
FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
On Error GoTo 0
End Function
If the file exists, you can:
Use VBA statement Kill (https://learn.microsoft.com/en-gb/office/vba/Language/Reference/user-interface-help/kill-statement) to delete the old file.
Use VBA statement Name (https://learn.microsoft.com/en-gb/office/vba/language/reference/user-interface-help/name-statement) to move the old file to another folder or rename it perhaps by adding a date at the beginning of the name.
I favour the second option because I do not like deleting a file until I am really, really sure I will not need it again. I saw too many situations during my career where a file deleted as no longer needed was found to be incorrectly or incompletely processed a few months later.
Once you have fully tested the macros, you can create the rules to execute them. For each type of email:
Select an email of the required type.
Click on Rules and then Create rule ….
Tick any relevant boxes on the first window.
Click Advanced options ….
Tick all relevant boxes on the second window.
Click Next.
Tick the box against “Run a script”.
Click a script.
You will be shown a list of all the macros that can be run from a rule. Select the required macro.
Click Next.
Tick the box against any appropriate exceptions and enter any additional information required.
Click Next.
Name the rule. Tick “run this rule against any messages already in Inbox” if required. Review the rule and edit if necessary.
Click Finish.
I hope the above is enough to plug the holes in your knowledge.
So I am very new with using Visual Basic and I am having trouble. I want to open a folder and read all the PDFs in the folder for content. I found this code on the Microsoft Guidelines, but received errors regarding expectations of certain codes:
For Each foundFile As String In My.Computer.FileSystem.GetFiles(
My.Computer.FileSystem.SpecialDirectories.MyDocuments,
Microsoft.VisualBasic.FileIO.SearchOption.SearchAllSubDirectories, "*.pdf")
Listbox1.Items.Add(foundFile)
Next
Does anyone know why I am getting such errors?
See if this is useful
Sub Dougsloop()
Dim Filename As String
Dim path As String
path = "path to folder" & "\"
Filename = Dir(path & "*.pdf")
Do While Len(Filename) > 0
debug.print; FileName
'Listbox1.Items.AddItem (Filename) replace debug w/this
Filename = Dir
Loop
End Sub
How to save specific incoming messages to the local hard drive programmatically
or
How to save an outlook folder to a local hard drive programmatically
either or works for me
The simplest way to save emails is using Outlook Rule + simple vba Script
Example
Option Explicit
Public Sub Save_Example(Item As Outlook.MailItem)
Dim Path As String
Dim FileName As String
Path = "C:\Temp\"
If Item.Subject = "Hello" Then
FileName = "Bla Bla" & ".msg"
Item.SaveAs Path & FileName, olMsg
End If
End Sub
I need to add text string to all files on a folder, as a footer
For example, on the folder on the path and called C:\mobatchscripts\
I have a random number of txt files, with text.
I want to add a line for example "text" on each of the text files on the folder
I have little knowledge of vba programming, but for what I have read I can use append, but I need something that loop on the files on the folder, and modify them.
So far I tried this:
Sub footer()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
FolderPath = "C:\mobatchscripts\"
FileName = Dir(FolderPath)
Do While FileName <> ""
Open FileName For Append As #1
Print #1, "test"
Close #1
FileName = Dir
Loop
End Sub
But seems that its not looking into the files, or appending the text.
On the assumption that you're writing to text files (I see "batchscripts" in the path), you need a reference to the Microsoft Scripting Runtime (Within the VBE you'll find it in Tools, References)
Option Explicit
Public Sub AppendTextToFiles(strFolderPath As String, _
strAppendText As String, _
blnAddLine As Boolean)
Dim objFSO As FileSystemObject
Dim fldOutput As Folder
Dim filCurrent As File
Dim txsOutput As TextStream
Set objFSO = New FileSystemObject
If objFSO.FolderExists(strFolderPath) Then
Set fldOutput = objFSO.GetFolder(strFolderPath)
For Each filCurrent In fldOutput.Files
Set txsOutput = filCurrent.OpenAsTextStream(ForAppending)
If blnAddLine Then
txsOutput.WriteLine strAppendText
Else
txsOutput.Write strAppendText
End If
txsOutput.Close
Next
MsgBox "Wrote text to " & fldOutput.Files.Count & " files", vbInformation
Else
MsgBox "Path not found", vbExclamation, "Invalid path"
End If
End Sub
I'd recommend adding error handling as well and possibly a check for the file extension to ensure that you're writing only to those files that you want to.
To add a line it would be called like this:
AppendTextToFiles "C:\mobatchscripts", "Test", True
To just add text to the file - no new line:
AppendTextToFiles "C:\mobatchscripts", "Test", False
Alternatively, forget the params and convert them to constants at the beginning of the proc. Next time I'd recommend working on the wording of your question as it's not really very clear what you're trying to achieve.