I have the following code to monitor a drive. Now I an getting Echo for each file creation or deletion event.
Is there and way to modify the WScript.Echo to send a mail notification?
strDrive = "c"
arrFolders(0) = strDrive & "\\\\"
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * FROM __InstanceOperationEvent WITHIN 1 " & "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" & " and TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & VbCrLf & vbTab & "Wscript.Echo objObject.TargetInstance.PartComponent" & VbCrLf & "End Sub"
WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Instead of Echoing like below:
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & VbCrLf & vbTab & "Wscript.Echo objObject.TargetInstance.PartComponent" & VbCrLf & "End Sub"
I want to send a mail like this:
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & VbCrLf & vbTab & "
Set outobj = CreateObject("Outlook.Application")
Set mailobj = outobj.CreateItem(0)
With mailobj
.To = toAddress
.Subject = Subject
.HTMLBody = strHTML
.Send
End With
" & VbCrLf & "End Sub"
Is it possible or is there an other way to do this..?
I don't know what server do you use, but on Windows 2003 and 2008 e.g. you can use CDO object to create a email. You might use a smart host to send your email to.
Check this link: http://www.paulsadowski.com/wsh/cdo.htm
Also you can choose any free email component to create a email and use a smtp server to send your email. Or check this side where you can use a component including many examples how to do it: http://www.chilkatsoft.com/email-activex.asp.
** UPDATED **
This Script checks and send a email as you requestted:
strDrive = "d:"
Dim arrFolders(0) : arrFolders(0) = strDrive & "\\\\"
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
WScript.Echo "setup for folder: " & strFolder & vbLf
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * " _
& "FROM __InstanceOperationEvent " _
& "WITHIN 1 " _
& "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" _
& " AND TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & vbLf _
& " Wscript.Echo objObject.TargetInstance.PartComponent" & vbLf _
& " SendMail(objObject.TargetInstance.PartComponent)" & vbLf _
& "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Function SendMail(vBody)
Dim oMail : Set oMail = CreateObject("CDO.Message")
'Name or IP of Remote SMTP Server
oMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "your.smtp.server"
oMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
oMail.Configuration.Fields.Update
oMail.Subject = "Email Watch Info Message"
oMail.From = "alert#yourdomain.net"
oMail.To = "target#yourdomain.net"
oMail.TextBody = vBody
oMail.Send
End Function
Correct the settings in the send mail function and your are fine.
In theory, the VBSendMail DLL should be able to do what you want.
Related
In Access 2010 I have tables, e.g. Employee(Pracownicy). I can update the data in the table using the subform and the update button.
Updating the data in the subform automatically generates an Outlook mail containing the data in the updated record.
I need to change font color for updated data in the mail body.
The code to update the data and generate e-mail:
Private Sub cmdUpdate2_Click()
CurrentDb.Execute "update Pracownicy" & _
" SET Identyfikator='" & Me.txtID & "'" & _
", Imie='" & Me.txtImie & "'" & _
", Nazwisko ='" & Me.txtNazwisko & "'" & _
", Wiek ='" & Me.txtWiek & "'" & _
", Data_urodzenia ='" & Me.txtData & "'" & _
", Miejsce_urodzenia ='" & Me.txtMiejsce & "'" & _
", Miejscowosc ='" & Me.txtMiejscowosc & "'" & _
", Plec ='" & Me.txtPlec & "'" & _
" where Identyfikator='" & Me.txtID & "'"
'------------------------------------SEND EMAIL----------------------
'Dim varName As Variant
'Dim strUCC As String
Dim varSubject As Variant
Dim varBody As Variant
Dim Poczta As Object
Dim MojMail As Object
On Error Resume Next
'varName = ""
varSubject = "Employer List "
varBody = "Hello" & _
"<br><br>Employer List: " & _
"<br><br><B>Identyfikator:</B> " & Me.txtID & " " & _
"<br><B>Imie:</B> " & Me.txtImie & " " & _
"<br><B>Nazwisko:</B> " & Me.txtNazwisko & " " & _
"<br><B>Wiek:</B> " & Me.txtWiek & " " & _
"<br><B>Data urodzenia:</B> " & Me.txtData & " " & _
"<br><B>Miejsce urodzenia:</B> " & Me.txtMiejsce & " " & _
"<br><B>Miejscowosc:</B> " & Me.txtMiejscowosc & " " & _
"<br><B>Plec:</B> " & Me.txtPlec & " "
Set Poczta = CreateObject("outlook.application")
Set MojMail = Poczta.createitem(0)
With MojMail
'.To =
'.BCC =
.subject = varSubject
'.ReadReceiptRequested = True
'.originatorDeliveryReportRequested = True
.htmlbody = varBody & "<br>"
.display
'.send
End With
Set Poczta = Nothing
Set MojMail = Nothing
If Err.Number <> 0 Then
MsgBox ("Atention")
End If
On Error GoTo 0
'------------------------------------------------------------------------
DoCmd.Close
MsgBox ("End Update")
End Sub
I think this becomes more of an HTML question rather than VBA. Try adding a FONT tag to the following line and see if that works for you.
"<br><br><B><font color="red">Identyfikator:</font></B> " & Me.txtID & " " & _
I'm able to use the below code to download files from server. However, this does tell me whether the files are downloaded successfully.
Sub DownloadFirstRunFilesPart2()
Application.StatusBar = "Downloading files..."
Dim wsh As Object
Dim errorcode4 As Integer
Dim cmd5 As Variant
Dim FirstRunFiles(5) As Variant
Dim var As Variant
FirstRunFiles(0) = ProN & "_KSParameter_UserInput.xlsx"
FirstRunFiles(1) = ProN & "_KSParameter_SysOutput.xlsx"
FirstRunFiles(2) = ProN & "_ModelParameter_UserInput.xlsx"
FirstRunFiles(3) = ProN & "_ModelParameter_SysOutput.xlsx"
FirstRunFiles(4) = ProN & "_VarClusParameter_UserInput.xlsx"
FirstRunFiles(5) = ProN & "_VarClusParameter_SysOutput.xlsx"
For Each var In FirstRunFiles
cmd5 = Chr(34) & "C:\Program Files (x86)" & "\PuTTY\pscp.exe" & Chr(34) & " -sftp -l " & pUser & " -pw " & pPass & _
" " & " " & pHost & ":" & ServerPath & "/" & var & " " & LocalPath & "\"
Set wsh = CreateObject("wscript.shell")
errorcode4 = wsh.Run(cmd5, vbHide)
'If errorcode4 = 0 Then MsgBox ("Error occurs. Fail to download " & var)
Next var
Application.StatusBar = "Download complete"
MsgBox ("Downloading process complete.")
End Sub
My error code always equals 0 no matter the file exists or not. How should I change this program?
Thanks in advance!
Update:
The new code that I tried:
Sub test()
Dim wsh As Object
Dim WshShellExec As Variant
Dim cmd3 As String
Dim pFirstRunFile1 As String
Const WshFinished = 1
Const WshFailed = 2
pFirstRunFile1 = "this_proj_name.txt"
cmd3 = Chr(34) & "C:\Program Files (x86)" & "\PuTTY\pscp.exe" & Chr(34) & " -sftp -l " & pUser & " -pw " & pPass & _
" " & " " & pHost & ":" & ServerPath & "/WOE/" & pFirstRunFile1 & " " & LocalPath & "\WOE"
Set wsh = CreateObject("wscript.shell")
WshShellExec = wsh.Exec(cmd3)
Select Case WshShellExec.Status
Case WshFinished
strOutput = WshShellExec.StdOut.ReadAll
Case WshFailed
strOutput = WshShellExec.StdErr.ReadAll
End Select
MsgBox strOutput 'write results in a message box
End Sub
However I'm getting error on this line:
WshShellExec = wsh.Exec(cmd3)
The error message says "Object does not support this property or method". Any ideas?
I am trying to call a .bat file from VBA using: however I am getting Method Run of object IWshShell3 failed with the line in asteriks highlighted. I am not familiar with this error and don't know where to begin. I am running VB in excel 2010. Thank you :).
Dim PathCrnt As String
Dim wsh As Object
PathCrnt = ActiveWorkbook.Path & "\" & MyBarCode & "_" & MyScan
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
**wsh.Run "C:\Users\cmccabe\Desktop\NxClinical.bat", windowStyle, waitOnReturn**
End If
EDIT
The code runs but exits with error code 1. Basically, what I am trying to do is have the user enter a barcode and date, those values are used to change the directory to that. A batch file is called that runs a perl script on that directory. The batch file is not being called and I'm not sure why. Thank you :).
VBA
Private Sub CommandButton3_Click()
Dim MyBarCode As String ' Enter Barcode
Dim MyScan As String ' Enter ScanDate
Dim MyDirectory As String
MyBarCode = Application.InputBox("Please enter the barcode", "Bar Code", Type:=2)
If MyBarCode = "False" Then Exit Sub 'user canceled
Do
MyScan = Application.InputBox("Please enter scan date", "Scan Date", Date, Type:=2)
If MyScan = "False" Then Exit Sub 'user canceled
If IsDate(MyScan) Then Exit Do
MsgBox "Please enter a valid date format. ", vbExclamation, "Invalid Date Entry"
Loop
Range("B20").Value = MyBarCode
Range("B21").Value = CDate(MyScan)
MyDirectory = "N:\1_DATA\MicroArray\NexusData\" & MyBarCode & "_" & Format(CDate(MyScan), "m-d-yyyy") & "\"
' Create nexus directory and folder
If Dir(MyDirectory, vbDirectory) = "" Then MkDir MyDirectory
If MsgBox("The project file has been created. " & _
"Do you want to create a template for analysis now?", _
vbQuestion + vbYesNo) = vbYes Then
'Write to text file
Open MyDirectory & "sample_descriptor.txt" For Output As #1
Print #1, "Experiment Sample" & vbTab & "Control Sample" & vbTab & "Display Name" & vbTab & "Gender" & vbTab & "Control Gender" & vbTab & "Spikein" & vbTab & "SpikeIn Location" & vbTab & "Barcode"
Print #1, MyBarCode & "_532Block1.txt" & vbTab & MyBarCode & "_635Block1.txt" & vbTab & ActiveSheet.Range("B8").Value & " " & ActiveSheet.Range("B9").Value & vbTab & ActiveSheet.Range("B10").Value & vbTab & ActiveSheet.Range("B5").Value & vbTab & ActiveSheet.Range("B11").Value & vbTab & ActiveSheet.Range("B12").Value & vbTab & ActiveSheet.Range("B20").Value
Print #1, MyBarCode & "_532Block2.txt" & vbTab & MyBarCode & "_635Block2.txt" & vbTab & ActiveSheet.Range("C8").Value & " " & ActiveSheet.Range("C9").Value & vbTab & ActiveSheet.Range("C10").Value & vbTab & ActiveSheet.Range("C5").Value & vbTab & ActiveSheet.Range("C11").Value & vbTab & ActiveSheet.Range("C12").Value & vbTab & ActiveSheet.Range("B20").Value
Print #1, MyBarCode & "_532Block3.txt" & vbTab & MyBarCode & "_635Block3.txt" & vbTab & ActiveSheet.Range("D8").Value & " " & ActiveSheet.Range("D9").Value & vbTab & ActiveSheet.Range("D10").Value & vbTab & ActiveSheet.Range("D5").Value & vbTab & ActiveSheet.Range("D11").Value & vbTab & ActiveSheet.Range("D12").Value & vbTab & ActiveSheet.Range("B20").Value
Print #1, MyBarCode & "_532Block4.txt" & vbTab & MyBarCode & "_635Block4.txt" & vbTab & ActiveSheet.Range("E8").Value & " " & ActiveSheet.Range("E9").Value & vbTab & ActiveSheet.Range("E10").Value & vbTab & ActiveSheet.Range("E5").Value & vbTab & ActiveSheet.Range("E11").Value & vbTab & ActiveSheet.Range("E12").Value & vbTab & ActiveSheet.Range("B20").Value
Close #1
'Run ImaGene
If MsgBox("Please run the ImaGene analysis. " & _
"and click yes after it completes to verify the spike-ins.", _
vbQuestion + vbYesNo) = vbYes Then
'Update folder structure and call perl
Dim PathCrnt As String
Dim Wsh As Object
Dim WaitOnReturn As Boolean
Dim WindowStyle As Integer
PathCrnt = MyDirectory
Set Wsh = VBA.CreateObject("WScript.Shell")
WaitOnReturn = True
WindowStyle = 1
Wsh.Run PathCrnt & "C:\Users\cmccabe\Desktop\NxClinical.bat", WindowStyle, WaitOnReturn
End If
Else
MsgBox "Nothing has been done. ", vbExclamation, "Goodbye!"
End If
Application.DisplayAlerts = False
Application.Quit
End Sub
Dim PathCrnt As String
Dim wsh As Object
PathCrnt = ActiveWorkbook.Path & "\" & MyBarCode & "_" & MyScan
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errrCode As Long
errrCode = wsh.Run( "cmd /C ""C:\Users\cmccabe\Desktop\NxClinical.bat""" _
, windowStyle, waitOnReturn)
If errrCode = 0 Then
MsgBox "Done! No error to report."
Else
MsgBox "Program exited with error code " & errrCode & "."
End If
Note
explicitly run cmd /c;
enclose batch script (fully qualified) name in double quotes;
get (and treat) errrCode from called batch script.
If your batch script requires paramer(s), use them as follows (an example):
errrCode = wsh.Run( "cmd /C ""C:\Users\cmccabe\Desktop\NxClinical.bat"" par1 ""par 2""" _
, windowStyle, waitOnReturn)
Another example:
errrCode = wsh.Run( "cmd /C ""C:\Users\cmccabe\Desktop\NxClinical.bat"" " _
_ & """" & PathCrnt & """" , windowStyle, waitOnReturn)
I am using the following vba code in outlook to count all the emails in a folder and subfolders. But I want to edit my code so that it only counts the unread emails.
Is there a way I can do this and if so would someone please be able to show me how?
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim objFolder2 As MAPIFolder
Dim objFolder3 As MAPIFolder
Dim objFolder4 As MAPIFolder
Dim objFolder5 As MAPIFolder
Dim objFolder6 As MAPIFolder
Dim objFolder7 As MAPIFolder
Dim objFolder8 As MAPIFolder
Dim objFolder9 As MAPIFolder
Dim objFolder10 As MAPIFolder
Dim objFolder11 As MAPIFolder
Dim objFolder12 As MAPIFolder
Dim objFolder13 As MAPIFolder
Dim objFolder14 As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("3PL & HAULAGE")
Set objFolder2 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("ACCOMODATION")
Set objFolder3 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("CORE FLEET & EQUIPMENT")
Set objFolder4 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("LUBRICANTS & OILS")
Set objFolder5 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("MARKETING")
Set objFolder6 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("PLANT EQUIPMENT & TOOLS")
Set objFolder7 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("PROPERTY & REFURBISHMENT")
Set objFolder8 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("SECURITY & SYSTEMS")
Set objFolder9 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("SERVICING & REPAIRS")
Set objFolder10 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("STATIONARY")
Set objFolder11 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("TESTING & CALIBRATING")
Set objFolder12 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("UTILITIES: GAS, FUEL, ELECTRICAL (ENERGY)")
Set objFolder13 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("X-HIRE CRANE HIRE")
Set objFolder14 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("X-HIRE PLANT EQUIPMENT")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
EmailCount2 = objFolder2.Items.Count
EmailCount3 = objFolder3.Items.Count
EmailCount4 = objFolder4.Items.Count
EmailCount5 = objFolder5.Items.Count
EmailCount6 = objFolder6.Items.Count
EmailCount7 = objFolder7.Items.Count
EmailCount8 = objFolder8.Items.Count
EmailCount9 = objFolder9.Items.Count
EmailCount10 = objFolder10.Items.Count
EmailCount11 = objFolder11.Items.Count
EmailCount12 = objFolder12.Items.Count
EmailCount13 = objFolder13.Items.Count
EmailCount14 = objFolder14.Items.Count
MsgBox "New Suppliers & New Business Report Sent"
TempFilePath = "\\UKSH000-File06\Purchasing\New_Supplier_Set_Ups_&_Audits\assets\"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<p style='color:#000;font-family:calibri;font-size:16'>Dear Jason," & vbNewLine & vbNewLine & _
"<br><br>" & "This is your weekly report, for " & "<b>" & "New Suppliers & New Business Introductions" & "</b>" & ", sent to you from NewSuppliers." & vbNewLine & _
"<br>" & "Please see a breakdown of different types of suppliers and new business below:" & vbNewLine & vbNewLine & _
"<br><br><br>" & "3PL & HAULAGE SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount & "</b></font>" & vbNewLine & _
"<br>" & "ACCOMODATION SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount2 & "</b></font>" & vbNewLine & _
"<br>" & "CORE FLEET & EQUIPMENT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount3 & "</b></font>" & vbNewLine & _
"<br>" & "LUBRICANT & OILS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount4 & "</b></font>" & vbNewLine & _
"<br>" & "MARKETING SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount5 & "</b></font>" & vbNewLine & _
"<br>" & "PLANT EQUIPMENT & TOOLS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount6 & "</b></font>" & vbNewLine & _
"<br>" & "PROPERTY & REFURBISHMENT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount7 & "</b></font>" & vbNewLine & _
"<br>" & "SECURITY & SYSTEMS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount8 & "</b></font>" & vbNewLine & _
"<br>" & "SERVICING & REPAIRS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount9 & "</b></font>" & vbNewLine & _
"<br>" & "STATIONARY SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount10 & "</b></font>" & vbNewLine & _
"<br>" & "TESTING & CALIBRATING SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount11 & "</b></font>" & vbNewLine & _
"<br>" & "UTILITIES & ENERGY SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount12 & "</b></font>" & vbNewLine & _
"<br>" & "X-HIRE CRANE SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount13 & "</b></font>" & vbNewLine & _
"<br>" & "X-HIRE PLANT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount14 & "</b></font>" & vbNewLine & _
"<br><br><br>" & "If you have any queries please reply to this email, NewSuppliers#Hewden.co.uk." & vbNewLine & vbNewLine & _
"<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
"<p style='color:#000;font-family:calibri;font-size:18'><b>Automated Purchasing Email</font></p></b>" & vbNewLine & _
"<br><br><img src='cid:cover.jpg'" & "width='800' height='64'><br>" & vbNewLine & _
"<img src='cid:subs.jpg'" & "width='274' height='51'>"
With OutMail
.SentOnBehalfOfName = "newsuppliers#hewden.co.uk"
.To = "mark.o'brien#hewden.co.uk"
.CC = ""
.BCC = ""
.Subject = "New Suppliers & New Business Introduction - Weekly Report"
.HtmlBody = strbody
.Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
.Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
Dim fso As Object
Dim fo As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.CreateTextFile("C:\Users\x152833\outlook_log.txt")
fo.Write msg
fo.Close
Set fo = Nothing
Set fso = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
You can use
unreadCount = myItems.Restrict("[Unread] = true").Count
You can also try to read the PR_CONTENT_UNREAD MAPI property (DASL name "http://schemas.microsoft.com/mapi/proptag/0x36030003") using MAPIFolder.PropertyAccessor.GetProperty (the property is not guaranteed to be present). If the property is not present, you can catch the exception and fall back to Items.Restrict, which always works, but is a lot less efficient than PR_CONTENT_UNREAD.
Take a look at the folder with OutlookSpy (I am its author - click IMAPIFolder button) to check if PR_CONTENT_UNREAD property is available in your particular case.
It turned out to be quite easy, all you have to do is iterate through the Items collection of your objfolder objects and check the UnRead property of the items like this:
For Each i In objFolder.items
If (i.UnRead) Then
EmailCount = EmailCount + 1
End If
Next
However, I highly recommend getting rid of all those variables named objFolderxy and EmailCountxy. There is a much better way to do this. Consider the following example:
Sub GetFolderStats()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim d
Set d = CreateObject("Scripting.Dictionary")
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.Folders("Mailbox - CENSORED").Folders("Inbox").Folders("Suppliers")
For Each folder In objFolder.Folders
emailcount = 0
For Each i In folder.items
If (i.UnRead) Then
emailcount = emailcount + 1
End If
Next
d.Add folder.Name, emailcount
Next
Set d = Nothing
Set objOutlook = Nothing
Set objnSpace = Nothing
Set objFolder = Nothing
End Sub
Now, you might not need the dictionary at all, just wanted to give you an example how you could iterate through the email folders instead of explicitly specifying their names.
Of course, instead of storing these data in the dictionary, you could create the html markup on-the-fly thus there would be no need to process the dictionary saving a for loop.
Hope I could help...
I am working on VBA, from which I have to call a vbscript by passing some values.
Here is the code:
''VBA
'Below values are on different cells of Excel file which I am reading
'into a global variable then pass it to vbscript.
'SFilename = VBscript file path
'QClogin = "abc"
'QCpassword = "abc"
'sDomain = "xyz"
'sProject = "xyz123"
'testPathALM = "Subject\xyz - Use it!\xyz_abc"
'QCurl = "http://xxx_yyy_zzz/qcbin/"
Set wshShell = CreateObject("Wscript.Shell")
Set proc = wshShell.exec("wscript " & SFilename & " " & QClogin & _
" " & "" & QCpassword & " " & "" & sDomain & " " & "" & sProject & _
" " & "" & testPathALM & " " & "" & QCurl & "")
''VBscript on some location
Dim strUserName, strPassword, strServer
strUserName = WScript.Arguments(0) '"abc"
Msgbox "strUserName : " & strUserName
strPassword = WScript.Arguments(1) '"abc"
Msgbox "strPassword : " & strPassword
strServer = WScript.Arguments(5) '"http://xxx_yyy_zzz/qcbin/"
Msgbox "strServer : " & strServer
Dim strDomain, strProject, strRootNode
strDomain = WScript.Arguments(2) '"xyz"
Msgbox "strDomain: " & strDomain
strProject = WScript.Arguments(3) '"xyz123"
Msgbox "strProject: " & strProject
strRootNode = WScript.Arguments(4) '"Subject\xyz - Use it!\xyz_abc"
Msgbox "strRootNode: " & strRootNode
Now, when I running the code, it is passing below values properly to vbscript:
QClogin = "abc"
QCpassword = "abc"
sDomain = "xyz"
sProject = "xyz123"
It is having issues with these:
testPathALM = "Subject\xyz - Use it!\xyz_abc"
QCurl = "http://xxx_yyy_zzz/qcbin/"
Now, wierd thing for me is, if I keep a cell empty for "testPathALM" which is having "Subject\xyz - Use it!\xyz_abc" as value, I am getting "QCurl" value properly in vbscript.
But, if I keep value "Subject\xyz - Use it!\xyz_abc" for "testPathALM", then I am getting "-" for strServer which suppose to be "QCurl" value and "Subject\xyz" for "strRootNode" which supposed to be "Subject\xyz - Use it!\xyz_abc".
I am unable to understand what is the issue here.
Thanks a ton in advance.
Safer to quote all of your parameters:
Set wshShell = CreateObject("Wscript.Shell")
Set proc = wshShell.exec("wscript """ & SFilename & """ """ & _
QClogin & """ """ & QCpassword & """ """ & _
sDomain & """ """ & sProject & """ """ & _
testPathALM & """ """ & QCurl & """")
Try a debug.print to make sure it looks as it should...