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
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