Question

好的，所以我在这里可能是一个嘴，应该惩罚自己并折磨自己。 VBA在Excel中是非常新的，所以请大声笑。我从事医疗保健工作，而编写代码是同事在创建电子表格时开始的工作。只是制作Google和YouTube视频，教自己做什么。为下面的怪物道歉。我知道声明中还有其他内容，用于我编写的其他宏。

在Outlook中，我有几个日历，可以安排不同的事情。我创建了一个电子表格，其中粘贴了有关网站的信息，并且有一些宏按钮可以为我生成约会和电子邮件。我已经将代码设置为可以设置约会的位置，但是所有这些都进入了我的主日历。我正在尝试将约会安排到其他日历上。我已经阅读了有关MAPI函数的信息，但是我似乎无法使其正常工作。如果可以的话，该位置位于\ myemail@me.com \ Calendar。日历的名称是SVN日历。我已经为此工作了几个星期，并一直画空白。任何帮助都将不胜感激。

Dim olApp As Outlook.Application
Dim olEmail As Outlook.MailItem
Dim olCal As Outlook.AppointmentItem
Dim olFolder As Outlook.Folder
Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
Dim rtf() As Byte

Dim rngTo As Range
Dim rngCC As Range
Dim rngSUB As Range
Dim rngCALloc As Range
Dim rngCALstart As Range
Dim rngCALend As Range
Dim rngBody As Range
Dim myItem As Object

Sub newTestCreateCalendarUSA1()
'Testing calendar to other calendar than main.  i.e. SVN Calendar.  can't identify the actual calendar.  damnit.'

Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
Set appt = olApp.CreateItem(olAppointmentItem)

With ActiveSheet
    Set rngCC = .Range("I34")
    Set rngCALloc = .Range("I5")
    Set rngCALstart = .Range("I11")
    Set rngCALend = .Range("I12")
    Set rngSUB = .Range("I33")
    Set rngSite = .Range("C2")
    Set rngLoc = .Range("C4")
    Set rngTYPE = .Range("B23")
    Set rngGON = .Range("C23")
    Set rngPurpose = .Range("C21")
    Set rngGoals = .Range("C22")
    Set rngDate = .Range("I1")
    Set rngDateStart = .Range("I8")
    Set rngDateEnd = .Range("I9")
    Set rngTime = .Range("I10")
    Set rngCAS = .Range("C26")

End With

MsgBox "Ensure all attendees are correct prior to sending invite."

    appt.MeetingStatus = olMeeting
    appt.RequiredAttendees = rngCC.Value
    appt.Subject = rngSUB.Value
    appt.Location = rngCALloc.Value
    appt.Start = rngCALstart.Value
    appt.End = rngCALend.Value
    appt.AllDayEvent = True
    m.BodyFormat = olFormatHTML
    m.HTMLBody = Range("I31").Value
    m.GetInspector().WordEditor.Range.FormattedText.Copy
    appt.GetInspector().WordEditor.Range.FormattedText.Paste
    appt.Display
    m.Close False

End Sub

编辑：感谢您指导我跟随文件夹树Niton。我试图理解整个GetNameSpace的内容，但无法使其正常工作。我猜这就是我不是程序员所得到的...

我确实发现的是要粘贴的其他代码，并让它在正确的日历上进行了约会。子SVN_Calendar_Invite（） SVN Calendar的试用版和其他代码 Dim oApp作为对象昏暗的oNameSpace作为命名空间作为对象的Dim oFolder

Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("0000000098F32312526B334EAEC97D94705E33FB0100C964D8D325E3554DA24A72FB876E3F600001912394000000")

With ActiveSheet
Set rngCC = .Range("I34")
Set rngCALloc = .Range("I5")
Set rngCALstart = .Range("I11")
Set rngCALend = .Range("I12")
Set rngSUB = .Range("I33")
Set rngSite = .Range("C2")
Set rngLoc = .Range("C4")
Set rngTYPE = .Range("B23")
Set rngGON = .Range("C23")
Set rngPurpose = .Range("C21")
Set rngGoals = .Range("C22")
Set rngDate = .Range("I1")
Set rngDateStart = .Range("I8")
Set rngDateEnd = .Range("I9")
Set rngTime = .Range("I10")
Set rngCAS = .Range("C26")

End With

With oFolder

Set olApt = oApp.CreateItem(olAppointmentItem)
With olApt
            .AllDayEvent = True
            .RequiredAttendees = rngCC.Value
            .Start = rngDateStart.Value
            .End = rngDateEnd.Value
            .Subject = rngSUB.Value
            .Location = rngLoc.Value
            .Body = "The body of your appointment note"
            .BusyStatus = olFree
            .Save
            .Move oFolder

 End With
    Set olNS = Nothing
    Set olApp = Nothing
    Set olApt = Nothing


End With

End Sub

我现在有几个问题。 1-如果我使用.Display调出日历项目以对其进行查看，则它根本不会显示。 2-即使是一整天的事件，并且每个单元格相隔3天，但它会将结束日期减去1天。 3-我必须手动邀请参与者，这违反了进行邀请的目的。

Answer 1

好的，所以我晚了大约两年。当我面临同样的问题时发现了这个线程。设法通过一些试验和错误来解决，所以这对我有用。所以你可能会为未来在谷歌上搜索相同答案的人试一试......

更多信息是我没有在工具下设置对 Outlook 的引用，因为我有很多用户文件。

'开始

'在这里分解重新输入cos stackoverflow format xxx

Sub Add_Appt_to_Main_Sub_Calendar()

Dim BOOK2 As Workbook
    Workbooks.Open Filename:= _
    "Name of your file.csv"

    'csv is readable by outlook but not excel, u need to change the file type first

    
   'start pulling data from your csv file here
    
'if you are not setting reference to outlook under tools, please define all your outlook names as Object
    
  Dim olAppts As Object
  Dim Calfolder As Object
'this to define the main calendar folder
  Dim Subfolder As Object
'this to define the sub calendar folder

    Set olApp = CreateObject("Outlook.Application")

    Set olNamespace = olApp.GetNamespace("MAPI")
    
Dim filter As Variant
'cos we dont want to keep import duplicate appt into outlook calendar so we need to create and define a filter

Dim olfolder As Object
'the folder picker by user

Dim strolFolder As String
' we want to get the name of the folder picker by user    
     
    Set olfolder = olApp.GetNamespace("MAPI").Pickfolder
    'olfolder.Display
    'how to find the name of the folder selected

    On Error Resume Next
    
    If olfolder = "" Then
    MsgBox "No calendar selected."
    
    Workbooks("Name of your file.csv").Close savechanges:=True
   'close the csv file if no calendar selected by user
    
    
    
    Exit Sub
    
    Else
    
     strolFolder = olfolder
'name of the file pick by user

     Set Calfolder = olNamespace.GetDefaultFolder(9)
'defaultfolder(9) is the main calendar by default tagged to user outlook acc
     strCalfolder = Calfolder
     'name of the sub folder

    MsgBox strolFolder
    MsgBox strCalfolder
    MsgBox (olfolder.folderpath)
    MsgBox (Calfolder.folderpath)
     'keep for debugging
     
     If olfolder.folderpath <> Calfolder.folderpath Then
    
    
    'this is the line that add appointment into sub calendar
     
    Set olAppts = olNamespace.GetDefaultFolder(9).Folders(strolFolder)
    'eg. Set olAppts = olNamespace.GetDefaultFolder(9).Folders("name of subfolder")
    
    
   'this is the main folder
    Set Calfolder = olNamespace.GetDefaultFolder(9)
    'MsgBox Calfolder
    
    'this is the sub folder i want to add in
    Set Subfolder = Calfolder.Folders(strolFolder)
    
    'MsgBox Subfolder
    
    'add appt to subfolder
    Set olAppt = Subfolder.items.Add
    
    'MsgBox (olfolder.EntryID)
    'MsgBox (olfolder)
    'MsgBox (olfolder.FolderPath)
    'keep for debugging

    r = 2
    Do Until Trim(Cells(r, 1).Value) = ""
    
        'filter by subject, start date and location
        'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
        'On Error Resume Next 'enable error-handling machine
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
        'Set olAppt = olAppts.items.Find(filter)
        'currently this does a check in your main calendar
        'if existing appointment based on subject, start date and location is not found, add appointment
        ' i need to do a search in the subcalendar instead of main calendar
        
        Set olAppt = olAppts.items.Find(filter)
        
        If TypeName(olAppt) = "Nothing" Then
            
            
            Set myAppt = Subfolder.items.Add
            'Set myAppt = olApp.CreateItem(1)
            'if using main use create, if use subfolder add
            
            myAppt.Subject = Cells(r, 2).Value
            myAppt.Location = Cells(r, 8).Value
            myAppt.Start = Cells(r, 7).Value
            myAppt.Categories = Cells(r, 3).Value
            myAppt.Duration = 120
            myAppt.BusyStatus = 2
            myAppt.ReminderSet = True
            myAppt.Body = Cells(r, 11).Value
            myAppt.Save
        End If

        r = r + 1
        
    Loop
        
            
    MsgBox "TCU added to sub calendar."
     'if picked folder is sub calendar

     Else
     
   Set olApp = CreateObject("Outlook.Application")
        
        strCalfolder = olNamespace.GetDefaultFolder(9)
        Set olNamespace = olApp.GetNamespace("MAPI")
        Set olAppts = olNamespace.GetDefaultFolder(9)
    
        r = 2
        Do Until Trim(Cells(r, 1).Value) = ""
    
        'filter by subject, start date and location
        'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
            On Error Resume Next 'enable error-handling machine
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
        Set olAppt = olAppts.items.Find(filter)
        
        'if existing appointment not found, add appointment
            If TypeName(olAppt) = "Nothing" Then
                Set myAppt = olApp.CreateItem(1)
                myAppt.Subject = Cells(r, 2).Value
                myAppt.Location = Cells(r, 8).Value
                myAppt.Start = Cells(r, 7).Value
                myAppt.Categories = Cells(r, 3).Value
                myAppt.Duration = 120
                myAppt.BusyStatus = 2
                myAppt.ReminderSet = True
                myAppt.Body = Cells(r, 11).Value
                myAppt.Save
            End If

            r = r + 1
        
            Loop
    MsgBox "TCU added to main calendar."

    End If


End If

   
    'end add appt

    'close ur csv file
    Workbooks("Name of your file.csv").Close savechanges:=True
    
End Sub

Excel VBA Outlook约会到非默认日历

1 个答案: