我在excel中创建一个UserForm,它将在我的Outlook日历中创建约会。除了开始和结束时间,一切正常。下面是我的代码,其中DTPicker1是约会的日期,DTPicker2和DTPicker3分别是开始和结束时间。它们采用dtpTime格式。约会是在正确的日期和主题创建的,除了时间之外,一切都正常。不知道我应该做些什么来修复它。任何帮助表示赞赏。谢谢!
Private Sub CommandButton1_Click()
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
On Error Resume Next
Worksheets("Sheet1").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Dim mysub, myStart, myEnd
mysub = TextBox1
myStart = DTPicker1 & DatePicker2
myEnd = DTPicker1 & DatePicker3
Set olAppItem = olApp.CreateItem(olAppointmentItem) 'creates a new appointment
With olAppItem
'set default appointment values
.Location = ""
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
.RequiredAttendees = ""
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = TextBox1
.Attachments.Add ("c:\temp\somefile.msg")
.Location = ""
.Body = ""
.ReminderSet = True
.BusyStatus = olBusy
.Categories = "Orange Category"
On Error GoTo 0
.Save 'saves the new appointment to the default folder
End With
Set olAppItem = Nothing
Set olApp = Nothing
MsgBox "Done !"
End Sub
答案 0 :(得分:0)
如果是我,我会在UI上提供任何体面的日期时间,然后在提交到Outlook时在VBA中格式化该单元格
Dim startDate
Dim endDate
startDate = Format(Range("A1").value, "yyyy-mm-dd")
endDate = Format(Range("A2").value, "yyyy-mm-dd")
' upload to outlook startDate, endDate, appointment details
答案 1 :(得分:0)
我发现了自己的错误。我需要在myStart和myEnd中用空格分隔出两个变量并将它们与“&”连接起来。而不是在下面的代码中看到的“+”。我还需要在我的时间DTPicker上使用TimeValue函数来正确格式化它。感谢大家的投入!
Dim mysub
Dim myStart, myEnd As Date
mysub = TextBox1
myStart = DTPicker1 & " " & TimeValue(DTPicker2)
myEnd = DTPicker1 & " " & TimeValue(DTPicker3)
Set olAppItem = olApp.CreateItem(olAppointmentItem) 'creates a new appointment
With olAppItem
'set default appointment values
.Location = ""
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
.RequiredAttendees = ""
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = TextBox1
.Attachments.Add ("c:\temp\somefile.msg")
.Location = ""
.Body = .Subject
.ReminderSet = True
.BusyStatus = olBusy
.Categories = "Orange Category" 'add this to be able to delete the test appointments
On Error GoTo 0
.Save 'saves the new appointment to the default folder