ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

½Ð°Ý¤@¤UVBA¥i¥H§ì¯S©w¤é´Á½d³òªºOUTLOOK¦æ¨Æ¾ä¦^¨Ó¶Ü?

½Ð°Ý¤@¤UVBA¥i¥H§ì¯S©w¤é´Á½d³òªºOUTLOOK¦æ¨Æ¾ä¦^¨Ó¶Ü?

POWERQUERY¨ú¸ê®Æ³t«×¤ñ¸ûºC¡A½d³ò¤]«Ü¤j
¤£¾å±oVBA¯à¤£¯àª½±µ¦s¨ú?

https://www.mrexcel.com/board/threads/outlook-calendar-vba.816885/


¦³§ä¨ì³o­Ó½d¨Ò¡A¥i¬O¥¦§ì¨ì"¦æ¨Æ¾ä"¡A§Ú·Q§ìªº¬O"¦@¥Î¦æ¨Æ¾ä"
½Ð°Ý­n­×§ï¨º¸Ì¡H

TOP

§Ú¤v¸g§ì¨ì·Q­nªº¦æ¨Æ¾ä¤F~~

TOP

  1. Public Sub ListAppointments()
  2. On Error GoTo ErrHand:

  3.     Application.ScreenUpdating = False

  4.     'This is an enumeration value in context of getDefaultSharedFolder
  5.     Const olFolderCalendar As Byte = 9

  6.     Dim olApp       As Object: Set olApp = CreateObject("Outlook.Application")
  7.     Dim olNS        As Object: Set olNS = olApp.GetNamespace("MAPI")
  8.     Dim olFolder    As Object
  9.     Dim olApt       As Object
  10.     Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("¦Û¤vªºEMAIL")
  11.     Dim NextRow     As Long
  12.     Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
  13. Dim FromDate As Date
  14.     Dim ToDate As Date
  15.    
  16.    
  17.     objOwner.Resolve

  18.     If objOwner.Resolved Then
  19.         Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar).Folders("¦@¥Î¦æ¨Æ¾ä")
  20.     End If

  21.     ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")

  22.     'Ensure there at least 1 item to continue
  23.     If olFolder.Items.Count = 0 Then Exit Sub

  24.     'Create an array large enough to hold all records
  25.     Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)

  26.     'Add the records to an array
  27.     'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
  28.     On Error Resume Next
  29.    FromDate = InputBox("Enter the start date (format: yyyy/mm/dd)")
  30.    ToDate = InputBox("Enter the end date(format: yyyy/mm/dd)")
  31.    For Each olApt In olFolder.Items
  32.     If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
  33.         myArr(0, NextRow) = olApt.Subject
  34.         myArr(1, NextRow) = olApt.Start
  35.         myArr(2, NextRow) = olApt.End
  36.         myArr(3, NextRow) = olApt.Categories
  37.         NextRow = NextRow + 1
  38.         Else
  39.         End If
  40.     Next
  41.     On Error GoTo 0

  42.     'Write all records to a worksheet from an array, this is much faster
  43.     ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

  44.     'AutoFit
  45.     ws.Columns.AutoFit

  46. cleanExit:
  47.     Application.ScreenUpdating = True
  48.     Exit Sub

  49. ErrHand:
  50.     'Add error handler
  51.     Resume cleanExit
  52. End Sub
½Æ»s¥N½X
¿Ã¹õÂ^¨úµe­± 2021-03-16 144905.jpg

¥H¤W³o¼Ë´N¯à¨ú¥X¦@¥Î¦æ¨Æ¾ä¸Ìªº¸ê®Æ

TOP

½Ð°Ý¤@¤UmyArr(4, NextRow) = ­n¼W¥[¤@­ÓAllDayEvent­n«ç»ò¼g?
­èµo²{¥þ¤Ñ¨Æ¥óªºµ²§ô¤é´Á·|¦h¤F¤@¤Ñ¥X¨Ó¡A·Q§ì¥þ¤Ñ¨Æ¥ó¦^¨Ó¦A§ï¼g
¥i¬O¤£·|¼g

TOP

        ÀR«ä¦Û¦b : ­n¥Î¤ß¡A¤£­n¾Þ¤ß¡B·Ð¤ß¡C
ªð¦^¦Cªí ¤W¤@¥DÃD