PDA

View Full Version : add individual rows to outlook calender with button



nelmey
01-14-2014, 06:28 AM
only been playing with vba for a couple of days but i could really use some help

i am trying to combine 3 pieces of code (that all work separately fine) to do 3 tasks in 1 action

see below for what i have so far.

first string is buttons down column p.

second string is to change these buttons so that they are red with the word no then when clicked green with the word yes.

third string is sending the information from the individual row that the button is on to outlook calendar as an appointment.

my problems are 1) I cant combine second string to third in order to get colors working and 2) i cant work the code in third string to follow the row that the button is on.

end result i am after are buttons that when pushed say yes (truck is booked for delivery) and this information is sent to outlook calendar with a 2 hour reminder (if pushing the button again so it said no deleted the previously made appointment that would be super)

anyone who can help me with this i would be eternally grateful


Sub CreateButtons()


Dim i As Long
Dim shp As Object
Dim dblLeft As Double
Dim dblTop As Double
Dim dblWidth As Double
Dim dblHeight As Double

With Sheets("Log sheet (deliver)")
dblLeft = .Columns("p:p").Left 'All buttons have same Left position
dblWidth = .Columns("p:p").Width 'All buttons have same Width
For i = 2 To 15 'Starts on row 2 and finishes row 20
dblHeight = .Rows(i).Height 'Set Height to height of row
dblTop = .Rows(i).Top 'Set Top top of row
Set shp = .Buttons.Add(dblLeft, dblTop, dblWidth, dblHeight)
shp.OnAction = "Appointments"
shp.Characters.Text = "No"



Next i
End With



End Sub
Sub CommandButton1_Click()
With CommandButton1
If .BackColor = vbGreen Then
.BackColor = vbRed
.Caption = "No"
Else
.BackColor = vbGreen
.Caption = "Yes"
End If
End With
End Sub




Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object

On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon

Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = Sheet2.Range("A2").Value
OLAppointment.Start = Sheet2.Range("G2").Value
OLAppointment.Duration = 15
OLAppointment.ReminderMinutesBeforeStart = 120
OLAppointment.Save

Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If

End Sub





11090

snb
01-14-2014, 07:13 AM
See:

http://www.snb-vba.eu/VBA_Outlook_external_en.html#L5

nelmey
01-14-2014, 12:29 PM
thanks snb but i was hoping someone might be able to take a look at the code for me

snb
01-14-2014, 12:33 PM
If you dive into the simple code I draw your attention to it's very easy to adapt that code to your own requirements.
The code you posted is much too redundant.

nelmey
01-14-2014, 12:50 PM
only all the pieces work the way they should until i try linking them together

nelmey
01-16-2014, 12:29 PM
could some one please help