My Outlook Address book by default storing e-mail addresses in the combination of upper and lower case letters, in that case below code is not working for me. Please advise.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Recipients As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim i
Dim prompt As String
On Error Resume Next
' use lower case for the address
' LCase converts all addresses in the To field to lower case
Checklist = "firstname.lastname#domain.com"
Set Recipients = Item.Recipients
For i = Recipients.Count To 1 Step -1
Set recip = Recipients.Item(i)
If InStr(LCase(recip), LCase(Checklist)) Then
prompt$ = "You sending this to this messgae to Treasurer " & Item.To & ". Are you sure you want to send it?"
If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
Next i
End Sub
Related
You'll have to excuse me for a repeat question but I just can't seem to understand the responses others have been posting. My coding skills are very limited (barely a year in vb 2006 and vs 2010)
I know that the sr has opened too many of the same file but I cant figure out a fix for it. Explaining it to me in simple concepts would be very helpful. Once again sorry for the newby-ness.
Project Explanation: Create a bowling league stats keeper. cmdRegisterBowler adds bowler name to a dat file (bowlers.dat). cmdEnterScores will write name and stats to games.dat file.
Private Sub cmdRegisterBowler_Click_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdRegisterBowler.Click
'BOWLER REGISTRATION
Dim Person As String
Dim Team As String
txtName.Text.ToUpper()
txtTeam.Text.ToUpper()
Person = txtName.Text
Team = txtTeam.Text
If Person <> "" And Team <> "" Then
If IsInFile(Person & " " & Team) = True Then
MessageBox.Show(Person & " is already in the file.", "Error")
txtName.Clear()
txtTeam.Clear()
txtName.Focus()
Else
'swb = stream writer bowlers file
Dim swb As IO.StreamWriter = IO.File.AppendText("bowlers.dat")
swb.WriteLine(Person & " " & Team)
swb.Close()
MessageBox.Show(Person & " has been added to the file.", "Information Added")
txtName.Clear()
txtTeam.Clear()
txtName.Focus()
End If
Else
MessageBox.Show("You must enter a name.", "Information Incomplete")
End If
End Sub
Function IsInFile(ByVal person As String) As String
If IO.File.Exists("bowlers.dat") Then
Dim sr As IO.StreamReader = IO.File.OpenText("bowlers.dat")
Dim individual As String
Do Until sr.EndOfStream
individual = sr.ReadLine
If individual = person Then
Return True
sr.Close()
End If
Loop
sr.Close()
End If
Return False
End Function
Private Sub cmdEnterScores_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdEnterScores.Click
'SCORE ENTRY
Dim Person As String
Dim Team As String
Dim Score1 As Double
Dim Score2 As Double
Dim Score3 As Double
Dim Average As Double
Dim Display As String = "{0,-10} {1,10} {2,20} {3,10} {4,10} {5,10} {6,10}"
Dim Total As Double
Person = txtName2.Text
Team = txtTeam2.Text
Score1 = Val(txtFirstGame.Text)
Score2 = Val(txtSecondGame.Text)
Score3 = Val(txtThirdGame.Text)
Total = Score1 + Score2 + Score3
Average = Total / 3
Dim swb As IO.StreamWriter = IO.File.AppendText("bowlers.dat")
'Checks for blank entries
If Person <> "" Then
'Checks to see if person is registered
If IsNotInFile(Person) Then
Dim Response As Integer
' Displays a message box with the yes and no options to register bowler.
Response = MsgBox(Prompt:="The bowler you have entered is currently not registered. Would you like to do so?", Buttons:=vbYesNo)
'Yes button was selected. Bowler is then registered to bowlers.dat
If Response = vbYes Then
''swb = stream writer bowlers file
swb.WriteLine(Person & " " & Team)
swb.Close()
MessageBox.Show(Person & " has been added to the file.", "Information Added")
'The no button was selected. Focus is set to bowler registration group box
Else : Response = vbNo
txtName2.Clear()
txtTeam2.Clear()
txtFirstGame.Clear()
txtSecondGame.Clear()
txtThirdGame.Clear()
txtName.Focus()
End If
'If no then clears score entry group box and sets focus back to bowler registr
txtName.Clear()
txtName.Focus()
Else
'Write scores to games.dat file
'swg = stream writer games file
Dim swg As IO.StreamWriter = IO.File.AppendText("games.dat")
swg.WriteLine(Name & " " & Team & " " & Score1 & " " & Score2 & " " & Score3)
swg.Close()
MessageBox.Show(Person & "'s stats added to the file.", "Information Added")
txtName.Clear()
txtName.Focus()
Dim Display2 As String = "{0,-10} {1,10} {2,20} {3,10} {4,10} {5,10} {6,10}"
lstDisplay.Items.Add(String.Format(Display2, Person, Team, Score1, Score2, Score3, Total, Average))
End If
Else
MessageBox.Show("You must enter a name.", "Information Incomplete")
End If
End Sub
Function IsNotInFile(ByVal person As String) As String
If IO.File.Exists("bowlers.dat") Then
Dim sr As IO.StreamReader = IO.File.OpenText("bowlers.dat")
Dim individual As String
Do Until sr.EndOfStream
individual = sr.ReadLine
If individual <> person Then
Return True
sr.Close()
End If
Loop
sr.Close()
End If
Return False
End Function
Heres all my code. Thanks for any help in advance.
I haven't used Visual Basic in quite a while, but I believe the solution is simple.
Basically, your interactions with the System.IO library are currently very optimistic. You should always wrap IO interactions within a TRY...CATCH...END TRY block.
Check it out here: MSDN Example of StreamReader.ReadLine
To illustrate more clearly my meaning, I've altered one of your functions here:
Function IsInFile(ByVal person As String) As String
Try
If IO.File.Exists("bowlers.dat") Then
Dim sr As IO.StreamReader = IO.File.OpenText("bowlers.dat")
Dim individual As String
Do Until sr.EndOfStream
individual = sr.ReadLine
If individual = person Then
Return True
sr.Close()
End If
Loop
sr.Close()
End If
Return False
Catch ie as IOException
MessageBox.Show("Failed to search for " & person & " in file.", "Error")
Return false
End Try
End Function
I'd apply similar logic to surround all your interactions with Files within your code. I'd also recommend against using MessageBox to report errors -- it's okay for small projects, but for anything larger you're going to want to look up using a logging framework. Or build a debug console into your application that you can selective turn on or off via configuration.
Im trying to get an input box to validate the entries a user will make.
i'm using the below script but cant get the validation to work, any help would be appreciated.
Sub inputbox()
Dim Manager As Long
On Error Resume Next
Application.DisplayAlerts = False
Manager = Application.inputbox(Prompt:="Please enter a manager.", Title:="Pick A Manager Name", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If Manager = "" Then
Exit Sub
ElseIf Manager <> Ben, Cameron, Chris, Martin, Peter Then
MsgBox "Incorrect Name, pick a new one!"
Else
MsgBox "Your input was " & Manager
End If
End Sub
Although a Sub name same as built in ones are not recommended, you can do what you are after like below.
First you need to change the InputBox Type to 2 (String), since you are comparing with String. Then you should make a function to check if the input is part of a Manager List.
Sub inputbox()
On Error Resume Next
Dim Manager As String
Manager = Application.inputbox(Prompt:="Please enter a manager name:", Title:="Pick A Manager Name", Type:=2)
If Manager <> "" Then
If IsManager(Manager) Then
MsgBox "Your input was " & Manager
Else
MsgBox "Incorrect Name, pick a new one!"
End If
End If
End Sub
Private Function IsManager(sTxt As String) As Boolean
Dim aManagers As Variant, oItem As Variant, bAns As Boolean
aManagers = Array("Ben", "Cameron", "Chris", "Martin", "Peter")
bAns = False
For Each oItem In aManagers
If LCase(oItem) = LCase(Trim(sTxt)) Then
bAns = True
Exit For
End If
Next
IsManager = bAns
End Function
UPDATE (Improved version suggested by Simon1979):
Private Function IsManager(sTxt As String) As Boolean
On Error Resume Next
Dim aManagers As Variant
aManagers = Array("Ben", "Cameron", "Chris", "Martin", "Peter")
IsManager = Not IsError(Application.WorksheetFunction.Match(Trim(sTxt), aManagers, 0))
End Function
Haven't used the InputBox with Excel but I imagine it will be very similar to the Access one. I use the below method to validate inputbox:
Dim strM as string
EnterManager:
strM = InputBox("Enter Manager.")
If StrPtr(strM) = 0 Then 'Cancel was pressed
' Handle what to do if cancel pressed
Exit Sub
ElseIf Len(strM) = 0 Then 'OK was pressed with nothing entered
MsgBox "You must enter a Manager."
GoTo EnterBuyer
End If
To add your criteria you could add on another If, I'm not sure you can use the approach you have for checking the list of names. Also don't understand how you compare a long Manager with a list of names Ben, Cameron, Chris, Martin, Peter, unless they are assigned variables, in which case I would suggest adding prefixes so it is more obvious such as lBen as opposed to strBen so you can easily see the difference in variable type.
If strM <> "Ben" And strM <> "Cameron" And strM <> "Chris" And strM <> _
"Martin" And strM <> "Peter" Then
MsgBox "Incorrect Name, pick a new one!"
Else
MsgBox "Your input was " & strM
End If
Ive been looking for a solution to this for a while now and need a bit of help.
I need to detect when someone sends me a message to my outlook account when it does not have attachents.
I have a situation that.
An email is sent to me
There is spacific text in the subject
It has an attachment
If it has an attachment it sends reply 1 and moves the message to folder A
If it does not have an attachmnet it sends reply 2.and moves the message into folder B
Any help would be welcome
Many thanks
You can do this very easily in VBScript, like so:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim m As Variant
Dim strBody As String
Dim intIn As Long
Dim intAttachCount As Integer, intStandardAttachCount As Integer
On Error GoTo handleError
'Edit the following line if you have a signature on your email that includes images or other files. Make intStandardAttachCount equal the number of files in your signature.
intStandardAttachCount = 0
strBody = LCase(Item.Body)
intIn = InStr(1, strBody, "original message")
If intIn = 0 Then intIn = Len(strBody)
intIn = InStr(1, Left(strBody, intIn), "attach")
intAttachCount = Item.Attachments.Count
If intIn > 0 And intAttachCount <= intStandardAttachCount Then
m = MsgBox("It appears that you mean to send an attachment," & vbCrLf & "but there is no attachment to this message." & vbCrLf & vbCrLf & "Do you still want to send?", vbQuestion + vbYesNo + vbMsgBoxSetForeground)
If m = vbNo Then Cancel = True
End If
handleError:
If Err.Number <> 0 Then
MsgBox "Outlook Attachment Reminder Error: " & Err.Description, vbExclamation, "Outlook Attachment Reminder Error"
End If
End Sub
This can be modified for your exact need, but it's pretty straightforward.
Simple Google search away. Give credit to the guy who wrote it.
trying to get some VBA code together to basically be able to run my rules from a button on my toolbar within outlook 2007. The following code runs the rules on my exchange server inbox, which is empty as everything moves to my "Personal Inbox". I just want to change the code below to read my personal inbox and not my exchange mailbox inbox. Have searched on the web and cant find my answer and hence my post -
Sub RunAllInboxRules()
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
'On Error Resume Next
' get default store (where rules live)
Set st = Application.Session.DefaultStore
' get rules
Set myRules = st.GetRules
' iterate all the rules
For Each rl In myRules
' determine if it's an Inbox rule
If rl.RuleType = olRuleReceive Then
' if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
' tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub
Try this. I have tested on my machine. This logs into the mailbox you are logged onto and runs the rules accordingly
Sub RunAllInboxRules()
Dim objOL As Outlook.Application
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
Dim fldInbox As Object
Dim gnspNameSpace As Outlook.NameSpace
'On Error Resume Next
' get default store (where rules live)
'Logs into Outlook session
Set objOL = Outlook.Application
Set gnspNameSpace = objOL.GetNamespace("MAPI") 'Outlook Object
'Logs into the default Mailbox Inbox
'set the store to the mailbox
Set st = gnspNameSpace.GetDefaultFolder(olFolderInbox).Store
' get rules
Set myRules = st.GetRules
' iterate all the rules
For Each rl In myRules
' determine if it's an Inbox rule
If rl.RuleType = olRuleReceive Then
' if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
' tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub
I'm changing some crufty old printing code to use the Visual Basic Print Dialog Control to pass printer information to a CrystalReport object. It works great except for one thing - the page selection box is consistently disabled no matter what flags I pass the object. Here is my code:
Public Enum PrintDialogFlags
NoFlag = 0
DisablePagesButton = 1
LoadIntoPrnObject = 2
AutoStartPrint = 4
End Enum
Public Function ShowPrintDialogCR(ByVal hwnd As Long, ByRef cr As CrystalReport, _
Optional PrintFlags As Long = 0) As Boolean
//this function assumes cr is a valid report object
On Error GoTo ShowPrintDialogCR_Error
Dim PD As New vbprndlglib.PrinterDlg
//load default settings
PD.PrinterName = Printer.DeviceName
PD.DriverName = Printer.DriverName
PD.Port = Printer.Port
PD.PaperBin = Printer.PaperBin
PD.CancelError = True
PD.flags = (vbprndlglib.cdlPDNoSelection Or vbprndlglib.cdlPDHidePrintToFile)
// commented the line below out to see if it was something with my logic
// Still disables page selection without this line
//If PrintFlags And DisablePagesButton Then PD.flags = PD.flags Or vbprndlglib.cdlPDNoPageNums
Printer.TrackDefault = False
PD.ShowPrinter (hwnd)
cr.PrinterPort = PD.Port
cr.PrinterDriver = PD.DriverName
cr.PrinterName = PD.PrinterName
cr.CopiesToPrinter = PD.Copies
If PD.flags And vbprndlglib.cdlPDPageNums Then
cr.PrinterStartPage = PD.FromPage
cr.PrinterStopPage = PD.ToPage
End If
If PrintFlags And PrintDialogFlags.LoadIntoPrnObject Then
//copy these settings to the printer object
Dim prn As Printer
For Each prn In Printers
If prn.DeviceName = PD.PrinterName Then
Set Printer = prn
Exit For
End If
Next prn
Printer.PaperBin = PD.PaperBin
Printer.PaperSize = PD.PaperSize
Printer.Duplex = PD.Duplex
Printer.Copies = PD.Copies
Printer.ColorMode = PD.ColorMode
Printer.Orientation = PD.Orientation
Printer.PrintQuality = PD.PrintQuality
End If
Set PD = Nothing
If PrintFlags And PrintDialogFlags.AutoStartPrint Then cr.Action = 1
ShowPrintDialogCR = True
Printer.TrackDefault = True
Exit Function
ShowPrintDialogCR_Error:
If Err.Number = 20545 Then //request cancelled by user
MsgBox "The print request was cancelled after being submitted to the print spooler." & vbNewLine & _
"If you cancelled a print to file dialog, this is a normal message. " & vbNewLine & _
"Otherwise, this message could mean your printer is not accepting print requests from us at this time." _
, vbOKOnly + vbExclamation, "Print Request Cancelled"
ErrorLogger Err, "ShowPrintDialogCR"
ElseIf Err.Number <> 32755 Then
//something else besides clicking cancel, show the error
MsgBox "Error " & Err.Number & " - " & Err.Description & vbNewLine & "Source: " & _
Err.Source & vbNewLine & vbNewLine & "Document not printed.", vbOKOnly + vbCritical, "Print Failure"
ErrorLogger Err, "ShowPrintDialogCR"
End If
Err.Clear
ShowPrintDialogCR = False
Printer.TrackDefault = False
End Function
I don't see what I'm doing wrong here. I've passed several combinations of unrelated flags just to see if the box would enable itself with no success. I've encountered VB6 quirks before and I'm really hoping this isn't one of them. Any help is much appreciated!
I found this in the KB article you linked to:
To enable the Select Pages portion of
the Print dialog box, Max must be set
to a number that is larger than Min.
So, at the very least, you need to set the Min and Max properties on the print dialog object to something reasonable before you set the flags:
PD.CancelError = True
'Set Min and Max to enable page selection'
PD.Min = 1
PD.Max = 32767 'Or any large number really'
PD.flags = (vbprndlglib.cdlPDNoSelection Or vbprndlglib.cdlPDHidePrintToFile)
In my own experimenting I also found out the following few things:
If you just set Min and Max, the page selection will default both the "To" and "From" fields to 1.
If you set Min to 1 and Max to -1, and also set FromPage to 1 and ToPage to -1, the "From" field will default 1 and the "To" field will be empty. It's interesting that this works since the documentation states that Max must be larger than Min, but it looks like -1 is treated more like an "empty" or "null" value.
If you set the vbPrnDlg.cdlPageNums flag, the Print Dialog will default to the Pages radio button when it's displayed. If you omit the vbPrnDlg.cdlPageNums flag, the dialog will default to the All radio button.