Please Note that I have changed address
Go to
Baking Ways / Productive Bytes



Search This Blog

Pages

Friday, November 18, 2011

Excel how to show all value in a filtered table in vba

Hi,

If you want to show all value from a filter table, you need to check if there the table is filtered first, otherwise the Sheet1.ShowAllData will fail.
This is the solution



With  Sheet1
If .AutoFilterMode Then
If .FilterMode Then
.ShowAllData
End If
End If
End With

Thursday, November 10, 2011

Formatting code for HTML display

Hi,

This is really a great link
http://www.manoli.net/csharpformat/


to format c# or VB.NET/VBA/VB code in HTML 4 format to display on the web

How to Create a task or appointment using VBA Code in outlook

Hi,
I have changed the original code at this link to show you how to create either a task or an appointment from an e-mail item.
This is very handy when you want quickly create task/appointment without wasting your time to attach the original mail.
The only problem is that the item is attached at the end of the file. This is due to a bug in Outlook 2008/2010 for which the postion item does not work.
Just copy and paste the code below into an outlook module to make it work.




Sub CreateTaskFromMail()
Const mailItem_c As String = "MailItem"
Dim OE As Outlook.Explorer
Dim MI As Outlook.MailItem
Dim AI As Outlook.AppointmentItem
Dim TI As Outlook.TaskItem

Set OE = Application.ActiveExplorer

'Abort sub if no item selected:
If OE.Selection.Count < 1 Then
MsgBox "Please select an already saved message before" & vbCrLf & _
"attempting to create a task" & vbCrLf & _
"with this button ...", vbInformation, "No message selected ..."
Exit Sub
'Abort sub if item selected is not a MailItem.
ElseIf TypeName(OE.Selection(1)) <> mailItem_c Then
MsgBox "You must select a mail item...", vbInformation, "Invalid selection..."
Exit Sub
End If

Set MI = OE.Selection(1)
Set TI = Application.CreateItem(olTaskItem)
With TI
.Subject = MI.Subject
.Body = .Body & vbCrLf & vbCrLf
.Body = .Body & "-----Original Message-----" & vbCrLf
.Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
.Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
.Body = .Body & "To: " & MI.To & vbCrLf
.Body = .Body & "Cc: " & MI.CC & vbCrLf
.Body = .Body & "Subject: " & MI.Subject & vbCrLf
.Body = .Body & vbCrLf
.Body = .Body & MI.Body
'.StartDate = Date
'.DueDate = Date + 1
'.ReminderTime = .DueDate & " 10:00"


Select Case MsgBox("Do you want to attach the original mail?" & vbLf, _
vbYesNoCancel + vbQuestion, "Add Mail as Attachment ...")
Case vbYes
TI.Body = "View Original Mail attacched at the bottom" & vbCrLf & TI.Body
TI.Attachments.Add MI, , 1 'Position does not work. It is a bug in Outlook 2008/2010
TI.Display
Case vbNo
TI.Display
Case vbCancel
Exit Sub
End Select



End With

End Sub



Sub CreateAppointmentFromMail()
Const mailItem_c As String = "MailItem"
Dim OE As Outlook.Explorer
Dim MI As Outlook.MailItem
Dim AI As Outlook.AppointmentItem
Dim TI As Outlook.TaskItem

Set OE = Application.ActiveExplorer

'Abort sub if no item selected:
If OE.Selection.Count < 1 Then
MsgBox "Please select an already saved message before" & vbCrLf & _
"attempting to create an appointment" & vbCrLf & _
"with this button ...", vbInformation, "No message selected ..."
Exit Sub
'Abort sub if item selected is not a MailItem.
ElseIf TypeName(OE.Selection(1)) <> mailItem_c Then
MsgBox "You must select a mail item...", vbInformation, "Invalid selection..."
Exit Sub
End If

Set MI = OE.Selection(1)
Set AI = Outlook.CreateItem(olAppointmentItem)
With AI
.Subject = MI.Subject
.Body = .Body & vbCrLf & vbCrLf
.Body = .Body & "-----Original Message-----" & vbCrLf
.Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
.Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
.Body = .Body & "To: " & MI.To & vbCrLf
.Body = .Body & "Cc: " & MI.CC & vbCrLf
.Body = .Body & "Subject: " & MI.Subject & vbCrLf
.Body = .Body & vbCrLf
.Body = .Body & MI.Body
'.StartDate = Date
'.DueDate = Date + 1
'.ReminderTime = .DueDate & " 10:00"


Select Case MsgBox("Do you want to attach the original mail?" & vbLf, _
vbYesNoCancel + vbQuestion, "Add Mail as Attachment ...")
Case vbYes
AI.Body = "View Original Mail attacched at the bottom" & vbCrLf & AI.Body
AI.Attachments.Add MI, , 1 'Position does not work. It is a bug in Outlook 2008/2010
AI.Display
Case vbNo
AI.Display
Case vbCancel
Exit Sub
End Select



End With

End Sub




Sub NewTaskOrAppoitmentFromMail()
Const mailItem_c As String = "MailItem"
Dim OE As Outlook.Explorer
Dim MI As Outlook.MailItem
Dim AI As Outlook.AppointmentItem
Dim TI As Outlook.TaskItem

Set OE = Application.ActiveExplorer

'Abort sub if no item selected:
If OE.Selection.Count < 1 Then
MsgBox "Please select an already saved message before" & vbCrLf & _
"attempting to create an appointment or task" & vbCrLf & _
"with this button ...", vbInformation, "No message selected ..."
Exit Sub
'Abort sub if item selected is not a MailItem.
ElseIf TypeName(OE.Selection(1)) <> mailItem_c Then
MsgBox "You must select a mail item...", vbInformation, "Invalid selection..."
Exit Sub
End If

Set MI = OE.Selection(1)
'Beep
Select Case MsgBox("Do you want to create a Task?" & vbLf & _
"To Add Task (Yes) / To Add Appointment (No) / To Quit (Cancel)" & _
vbCrLf, vbYesNoCancel + vbQuestion, "Create a task or appointment ...")
Case vbNo 'If No, create appointment
Set AI = Outlook.CreateItem(olAppointmentItem)
With AI
.Subject = MI.Subject
.Body = "View Original Mail attacched at the bottom"
.Body = .Body & vbCrLf & vbCrLf
.Body = .Body & "-----Original Message-----" & vbCrLf
.Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
.Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
.Body = .Body & "To: " & MI.To & vbCrLf
.Body = .Body & "Cc: " & MI.CC & vbCrLf
.Body = .Body & "Subject: " & MI.Subject & vbCrLf
.Body = .Body & vbCrLf
.Body = .Body & MI.Body
.Attachments.Add MI, , 1
.Display
End With
Case vbYes
'If Yes, create task with no due or start date
Set TI = Application.CreateItem(olTaskItem)
With TI
.Subject = MI.Subject
.Body = "View Original Mail attacched at the bottom"
.Body = .Body & vbCrLf & vbCrLf
.Body = .Body & "-----Original Message-----" & vbCrLf
.Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
.Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
.Body = .Body & "To: " & MI.To & vbCrLf
.Body = .Body & "Cc: " & MI.CC & vbCrLf
.Body = .Body & "Subject: " & MI.Subject & vbCrLf
.Body = .Body & vbCrLf
.Body = .Body & MI.Body
.Attachments.Add MI, , 1

'.StartDate = Date
'.DueDate = Date + 1
'.ReminderTime = .DueDate & " 10:00"
'.Save
.Display



End With
'Case vbCancel
' Exit Sub
End Select
End Sub