The macro below is designed to take x amount of emails, count how many attachments there are in each mail and then locate certain file formats. It will then record what it has found in a certain excel spreadsheet.
The macro works perfectly, but I am now wanting to add in another scenario. The scenario I want to add in is that of if an email has more than 1 .csv file, it shall be recorded as "Multiple" rather than "YES".
Has anyone got any ideas to implement this scenario?
If .Attachments.Count = 0 Then
csv_report = "NO"
pdf_report = "NO"
xls_report = "NO"
End If
If .Attachments.Count > 0 Then
For i2 = 1 To .Attachments.Count
If LCase(Right(.Attachments(i2).Filename, 4)) = ".csv" Then
csv_report = "YES"
GoTo CSVyes 'if a .csv file is found, it skips to the PDF attachment checker
Else
csv_report = "NO"
End If
Next
CSVyes:
For i2 = 1 To .Attachments.Count
If LCase(Right(.Attachments(i2).Filename, 4)) = ".pdf" Then
pdf_report = "YES"
GoTo PDFyes 'if a .pdf file is found, it skips to the XLS attachment checker
Else
pdf_report = "NO"
End If
Next
PDFyes:
For i2 = 1 To .Attachments.Count
If LCase(Right(.Attachments(i2).Filename, 4)) = ".xls" Or LCase(Right(.Attachments(i2).Filename, 5)) = ".xlsx" Or UCase(Right(.Attachments(i2).Filename, 4)) = ".XLS" Then
xls_report = "YES"
GoTo XLSyes 'if a .xls file is found, it skips to the end of the checks
Else
xls_report = "NO"
End If
Next
XLSyes:
End If
Sheets("Mail Report").Activate
Range("C65000").End(xlUp).Offset(1).Value = csv_report
Range("D65000").End(xlUp).Offset(1).Value = pdf_report
Range("E65000").End(xlUp).Offset(1).Value = xls_report
subject_line = mail.Subject
Range("A65000").End(xlUp).Offset(1).Value = subject_line
Check this below code. I have just added If Else block to check if Attachment.count > 1. THat's It.
If .Attachments.Count > 0 Then
For i2 = 1 To .Attachments.Count
If LCase(Right(.Attachments(i2).Filename, 4)) = ".csv" Then
If .Attachments.Count > 1
csv_report = "MULTIPLE"
Else
csv_report = "YES"
End If
GoTo CSVyes 'if a .csv file is found, it skips to the PDF attachment checker
Else
csv_report = "NO"
End If
Next
After many attempts to implement this scenario, I was unsuccessful. So I figured to put an alternative method after this macro.
This macro is just a minor part of a much larger scale macro, but basically when there was blanks left in Column B I would replace a "YES" with "Multiple", which was sufficient to the outcome.
Dim kk As Long
Sheets("Mail Report").Activate
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For kk = 1 To LastRow
If IsEmpty(Cells(kk, 2)) Then
Cells(kk, 2) = MAIN_PATH & "For Resolution\" & "multiple_csv\"
Cells(kk, 3) = "MULTIPLE"
End If
Next kk
Related
Is it possible to make a script that allows sending email FROM:alias address including FROM:distribution address. I found a script that is only for FROM:alias address, but I didn't find a script for FROM:distribution address. The script is this:
Sub OnAcceptMessage(oClient, oMessage)
On Error Resume Next
If oClient.Username <> "" Then
If LCase(oClient.Username) <> LCase(oMessage.FromAddress) Then
Dim obBaseApp
Set obBaseApp = CreateObject("hMailServer.Application")
Call obBaseApp.Authenticate("Administrator","password") 'PUT HERE YOUR PASSWORD
StrClientDomain = Mid(oClient.Username,InStr(oClient.Username,"#") + 1)
StrFromDomain = Mid(oMessage.FromAddress,InStr(oMessage.FromAddress,"#") + 1)
Dim obDomain
Set obDomain = obBaseApp.Domains.ItemByName(StrClientDomain)
Dim obAliases
Dim obAlias
AliasFound = False
If LCase(StrClientDomain) <> LCase(StrFromDomain) Then
Set obAliases = obDomain.DomainAliases
For iAliases = 0 To (obAliases.Count - 1)
Set obAlias = obAliases.Item(iAliases)
if LCase(obAlias.AliasName) = LCase(StrFromDomain) Then
AliasFound = True
Exit For
End If
Next
If AliasFound Then
StrFromAddress = Left(oMessage.FromAddress, Len(oMessage.FromAddress) - Len(StrFromDomain)) + StrClientDomain
End If
Else
StrFromAddress = oMessage.FromAddress
AliasFound = True
End If
I found these variables for Distribution list in this code:
Sub OnAcceptMessage(oClient, oMessage)
Dim IsDistributionList : IsDistributionList = False
Dim Ogg, i, j, Recip, Dom, DomObj, DistListObj
For j = 0 to oMessage.Recipients.Count -1
Recip = oMessage.Recipients(j).OriginalAddress
Dom = (Split(Recip, "#"))(1)
Set DomObj = oApp.Domains.ItemByName(Dom)
If DomObj.DistributionLists.Count > 0 Then
For i = 0 To DomObj.DistributionLists.Count - 1
Set DistListObj = DomObj.DistributionLists.Item(i)
If Recip = DistListObj.Address Then
IsDistributionList = True
End If
Next
End If
Next
If IsDistributionList Then
Ogg = "[" & DistListObj.Address & "] "
Ogg = Ogg & oMessage.subject
oMessage.subject = Ogg
oMessage.Save
End If
End Sub
I am somewhat new to vba, and I'm trying to create a somewhat more complex conditional format than access 2013 allows from the conditional formatting menu. I have a form with 22 target date and actual date fields. for each pair I need to:
if the target date is more than 7 days in the future, color it green.
If the target date is less than 7 days in the future or is today, color it yellow
If the target date in the past, color it red.
UNLESS there is an actual date it was accomplished, in which case:
If the actual date is before the target date, color both dates green
If the actual date is after the target date, color both dates red.
Because I have to do this on form load, and on the change of any date field (the target dates are calculated, but will change if other data is changed in the form), I wanted to write a public sub that takes form name, target date, and actual date as variables. I was able to code each box to do this on the local form module with 'Me.txtbox'
However, when I try to reference the form and text boxes from the public sub, it seems like I'm not properly referencing the text boxes on the form. I've tried 3 or 4 different ways of doing this (string, textbox.name, etc) and I feel like I'm close, but ...
Code that works as desired in the form module
Private Sub txtFreqReqDate_AfterUpdate()
If Me.txtFreqReqDate <= Me.txtFreqReq Then
Me.txtFreqReq.Format = "mm/dd/yyyy[green]"
Me.txtFreqReqDate.Format = "mm/dd/yyyy[green]"
ElseIf Me.txtFreqReqDate > Me.txtFreqReq Then
Me.txtFreqReq.Format = "mm/dd/yyyy[red]"
Me.txtFreqReqDate.Format = "mm/dd/yyyy[red]"
ElseIf IsNull(Me.txtFreReqDate) = True Then
If Me.txtFreqReq < Now() Then
Me.txtFreqReq.Format = "mm/dd/yyyy[red]"
ElseIf Me.txtFreqReq >= (Now()+7) Then
Me.txtFreqReq.Format = "mm/dd/yyyy[yellow]"
ElseIf Me.txtFreqReq > (Now()+7) Then
Me.txtFreqReq.Format = "mm/dd/yyyy[green]"
Else
Me.txtFreqReq.Format = "mm/dd/yyyy[black]"
End If
Else
Exit Sub
End If
End Sub
Perhaps not the prettiest, but I'm always open to constructive criticism. I'd have to write this 22+ times for each pair, changing the name of the text boxes each time. I want to write a public sub that just takes the names of the text boxes, but I can't seem to find the right combination:
Private Sub txtFreqReqDate_AfterUpdate()
FormatBoxes(Me, me.txtFreqReqDate, me.txtFreqReq)
End Sub
And in another module:
Public Sub FormatBoxes(CurrentForm As Form, txtActual as Textbox, txtTarget as Textbox)
frmName = CurrentForm.name
tbActual = txtActual.Name
tbTarget = txtTarget.Name
If frmName.tbActual <= frmName.tbTarget Then
frmName.tbTarget.Format = "mm/dd/yyyy[green]"
frmName.tbActual.Format = "mm/dd/yyyy[green]"
ElseIf frmName.tbActual > frmName.tbTarget Then
frmName.tbTarget.Format = "mm/dd/yyyy[red]"
frmName.tbActual.Format = "mm/dd/yyyy[red]"
ElseIf IsNull(frmName.tbActual) = True Then
If frmName.tbTarget < Now() Then
frmName.tbTarget.Format = "mm/dd/yyyy[red]"
ElseIf frmName.tbTarget >= (Now()+7) Then
frmName.tbTarget.Format = "mm/dd/yyyy[yellow]"
ElseIf frmName.tbTarget > (Now()+7) Then
frmName.tbTarget.Format = "mm/dd/yyyy[green]"
Else
frmName.tbTarget.Format = "mm/dd/yyyy[black]"
End If
Else
Exit Sub
End If
End Sub
Sorry if this is a bit long, I'm just at my wit's end...
Also, apologies for any typos. I had to re-type this from another machine.
You can simply use the textbox parameters directly in your sub.
It is not even necessary to pass the form as parameter.
Public Sub FormatBoxes(txtActual as Textbox, txtTarget as Textbox)
If txtActual.Value <= txtTarget.Value Then
txtTarget.Format = "mm/dd/yyyy[green]"
etc.
Note that when calling it, you need either Call or remove the parentheses.
Private Sub txtFreqReqDate_AfterUpdate()
Call FormatBoxes(me.txtFreqReqDate, me.txtFreqReq)
' or
' FormatBoxes me.txtFreqReqDate, me.txtFreqReq
End Sub
CurrentForm.name is a string. It is the Name property of the CurrentForm object. The CurrentForm object also has a controls collection in which the texboxes live. You can refer to them by name in there like CurrentForm.Controls("tbTarget") but you can also say CurrentForm.tbTarget. So you're very close and on the right track.
Change
frmName = CurrentForm.name
tbActual = txtActual.Name
tbTarget = txtTarget.Name
to
set frmName = CurrentForm
if frmName is not nothing then
set tbActual = txtActual
set tbTarget = txtTarget
end if
Alternatively if your signature on your method is
Public Sub FormatBoxes(CurrentForm As string, txtActual as string, txtTarget as string)
then your set up will look like
set frmName = forms(CurrentForm)
if frmName is not nothing then
set tbActual = frmName.controls(txtActual)
set tbTarget = frmName.controls(txtTarget)
end if
But I think the first one will work better.
I wanted to post the finished code to help out anyone else who searches for this subject. I did a couple thins to make this sub more universal.
First, Instead of using the date format, I only changed the .ForeColor, allowing me to use this sub for any type of textbox.
Public Sub FormatBoxes(txtActual As TextBox, txtTarget As TextBox, chkRequired As CheckBox, _
Optional intOption as Integer)
Dim intRed As Long, intYellow As Long, intGreen As Long, inBlack As Long, intGray As Long
intBlack = RGB(0, 0, 0)
intGray = RGB(180, 180, 180)
intGreen = RGB (30, 120, 30)
intYellow = RGB(217, 167, 25)
intRed = RGB(255, 0, 0)
If (chkRequired = False) Then
txtTarget.ForeColor = intGray
txtActual.ForeColor = intGray
If intOption <> 1 Then
txtTarget.Enabled = False
txtActual.Enabled = False
txtTarget.TabStop = False
txtActual.TabStop = False
End If
Else
If intOption <> 1 Then
txtTarget.Enabled = True
txtActual.Enabled = True
txtTarget.Locked = True
txtActual.Locked = False
txtTarget.TabStop = False
txtActual.TabStop = True
End If
If IsBlank(txtActual) = True Then
If txtTarget < Now() Then
txtTarget.ForeColor = intRed
ElseIf txtTarget > (Now() + 7) Then
txtTarget.ForeColor = intGreen
ElseIf txtTarget >= Now() And txtTarget <= (Now() +7) Then
txtTarget.ForeColor = intYellow
Else
txtTarget.ForeColor = intBlack
End If
ElseIf intOption - 1 Then
txtTarget.ForeColor = intBlack
txtActual.ForeColor = intBlack
ElseIf txtActual <= txtTarget Then
txtTarget.ForeColor = intGreen
txtActual.ForeColor = intGreen
ElseIf txtActual > txtTarget Then
txtTarget.ForeColor = intRed
txtActual.ForeColor = intRed
End If
End If
End Sub
In case you were wondering, IsBlank() is a function that checks for a null or zero length string:
Public Function IsBlank(str_in As Variant) As Long
If Len(str_in & "") = 0 Then
IsBlank = -1
Else
IsBlank = 0
End If
End Function
Thanks for all the help, and I hope this is useful for someone.
This one has me stumped. I am populating a Listbox with a range and then formatting column 4 as d/mm/yyyy. This works fine if all cells in column 4 have a date. As some cells that are populated into the Listbox are in fact blank the sub crashes when it hits these cells. I have tried various if and else statements to skip the activecell if blank with no luck.
Grateful for any assistance.
Alex V
Sub populate_listbox_1()
Dim I As Long
Dim I2 As Long
Dim list_count As Long
Dim MyData As Range
Dim r As Long
With edit_report_input.compliments_listbox
.ColumnCount = 17
.ColumnWidths = "70;300;75;90;80;80;100;0;0;0;0;0;0;0;0;20;0"
.RowSource = ""
Set MyData = ActiveSheet.Range("A4:Q498") 'Adjust the range accordingly
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 1) = "" Then
.RemoveItem r
End If
Next r
End With
For I = 0 To edit_report_input.compliments_listbox.ListCount - 1
edit_report_input.compliments_listbox.List(I, 4) = Format(DateValue(edit_report_input.compliments_listbox.List(I, 4)), "d/mm/yyyy")
Next I
date_rec_compliment = Format(date_rec_compliment, "d/mm/yyyy")
End Sub
you can always check before changing the format. See if below snippet helps
For I = 0 To edit_report_input.compliments_listbox.ListCount - 1
if edit_report_input.compliments_listbox.List(I, 4) <> "" Then
edit_report_input.compliments_listbox.List(I, 4) = Format(DateValue(edit_report_input.compliments_listbox.List(I, 4)), "d/mm/yyyy")
End If
Next I
I've been working on this for 2 days. Basically I have 2 ListBoxes and I want a command button to compare the values and show the non-matching values (those that appear in the first listbox but not in the 2nd) and list them in the 3rd listbox. I'm not sure if this is the best way to go about it but here's my code. It errors on the line with the message:
Wrong number of arguments or invalid property assignment
My listboxes are named CompList1, CompList2 and CompList3.
Dim BoolAdd As Boolean, I As Long, j As Long
'Set initial Flag
BoolAdd = True
'If CompList2 is empty then abort operation
If CompList2.ListCount = 0 Then
MsgBox "Nothing to compare"
Exit Sub
'If CompList1 is empty then copy entire CompList2 to CompList3
ElseIf CompList1.ListCount = 0 Then
For I = 0 To CompList2.ListCount
CompList3.AddItem CompList2.Value
Next I
Else
For I = CompList2.ListCount - 1 To 0 Step -1
For j = 0 To CompList1.ListCount
If CompList2.ListCount(I) = CompList1.ListCount(j) Then
'If match found then abort
BoolAdd = False
Exit For
End If
DoEvents
Next j
'If not found then add to CompList3
If BoolAdd = True Then CompList3.AddItem CompList2.Value
DoEvents
Next I
End If
Some notes:
Dim tdf1 As TableDef
Dim tdf2 As TableDef
Dim db As Database
Set db = CurrentDb
Set tdf1 = db.TableDefs(Me.CompList1.RowSource)
For Each fld In tdf1.Fields
sFields = sFields & ";" & fld.Name
Next
sFields = sFields & ";"
Set tdf2 = db.TableDefs(Me.CompList2.RowSource)
For Each fld In tdf2.Fields
sf = ";" & fld.Name & ";"
sFields = Replace(sFields, sf, ";")
Next
Me.CompList3.RowSource = Mid(sFields,2)
Edit:
I have recovered some Word documents from a corrupted hard drive using a piece of software called photorec. The problem is that the documents' names can't be recovered; they are all renamed by a sequence of numbers. There are over 2000 documents to sort through and I was wondering if I could rename them using some automated process.
Is there a script I could use to find the first 10 letters in the document and rename it with that? It would have to be able to cope with multiple documents having the same first 10 letters and so not write over documents with the same name. Also, it would have to avoid renaming the document with illegal characters (such as '?', '*', '/', etc.)
I only have a little bit of experience with Python, C, and even less with bash programming in Linux, so bear with me if I don't know exactly what I'm doing if I have to write a new script.
How about VBScript? Here is a sketch:
FolderName = "C:\Docs\"
Set fs = CreateObject("Scripting.FileSystemObject")
Set fldr = fs.GetFolder(Foldername)
Set ws = CreateObject("Word.Application")
For Each f In fldr.Files
If Left(f.name,2)<>"~$" Then
If InStr(f.Type, "Microsoft Word") Then
MsgBox f.Name
Set doc = ws.Documents.Open(Foldername & f.Name)
s = vbNullString
i = 1
Do While Trim(s) = vbNullString And i <= doc.Paragraphs.Count
s = doc.Paragraphs(i)
s = CleanString(Left(s, 10))
i = i + 1
Loop
doc.Close False
If s = "" Then s = "NoParas"
s1 = s
i = 1
Do While fs.FileExists(s1)
s1 = s & i
i = i + 1
Loop
MsgBox "Name " & Foldername & f.Name & " As " & Foldername & s1 _
& Right(f.Name, InStrRev(f.Name, "."))
'' This uses copy, because it seems safer
f.Copy Foldername & s1 & Right(f.Name, InStrRev(f.Name, ".")), False
'' MoveFile will copy the file:
'' fs.MoveFile Foldername & f.Name, Foldername & s1 _
'' & Right(f.Name, InStrRev(f.Name, "."))
End If
End If
Next
msgbox "Done"
ws.Quit
Set ws = Nothing
Set fs = Nothing
Function CleanString(StringToClean)
''http://msdn.microsoft.com/en-us/library/ms974570.aspx
Dim objRegEx
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Global = True
''Find anything not a-z, 0-9
objRegEx.Pattern = "[^a-z0-9]"
CleanString = objRegEx.Replace(StringToClean, "")
End Function
Word documents are stored in a custom format which places a load of binary cruft on the beginning of the file.
The simplest thing would be to knock something up in Python that searched for the first line beginning with ASCII chars. Here you go:
#!/usr/bin/python
import glob
import os
for file in glob.glob("*.doc"):
f = open(file, "rb")
new_name = ""
chars = 0
char = f.read(1)
while char != "":
if 0 < ord(char) < 128:
if ord("a") <= ord(char) <= ord("z") or ord("A") <= ord(char) <= ord("Z") or ord("0") <= ord(char) <= ord("9"):
new_name += char
else:
new_name += "_"
chars += 1
if chars == 100:
new_name = new_name[:20] + ".doc"
print "renaming " + file + " to " + new_name
f.close()
break;
else:
new_name = ""
chars = 0
char = f.read(1)
if new_name != "":
os.rename(file, new_name)
NOTE: if you want to glob multiple directories you'll need to change the glob line accordingly. Also this takes no account of whether the file you're trying to rename to already exists, so if you have multiple docs with the same first few chars then you'll need to handle that.
I found the first chunk of 100 ASCII chars in a row (if you look for less than that you end up picking up doc keywords and such) and then used the first 20 of these to make the new name, replacing anything that's not a-z A-Z or 0-9 with underscores to avoid file name issues.