52 lines
1.8 KiB
Text
52 lines
1.8 KiB
Text
|
Sub SletAltiplanBegivenheder()
|
||
|
|
Dim nms As NameSpace
|
||
|
|
Dim fld As Folder
|
||
|
|
Dim itm As Object
|
||
|
|
Dim i As Long
|
||
|
|
Dim kategoriNavn As String
|
||
|
|
Dim sletAntal As Long
|
||
|
|
Dim svar As VbMsgBoxResult
|
||
|
|
|
||
|
|
' Definition af kategorien
|
||
|
|
kategoriNavn = "Fra Altiplan"
|
||
|
|
sletAntal = 0
|
||
|
|
|
||
|
|
' Sikkerhedsspørgsmål før vi går i gang
|
||
|
|
svar = MsgBox("Vil du slette alle kalenderbegivenheder med kategorien '" & kategoriNavn & "'?", _
|
||
|
|
vbQuestion + vbYesNo, "Bekræft sletning")
|
||
|
|
|
||
|
|
If svar = vbNo Then Exit Sub
|
||
|
|
|
||
|
|
Set nms = Application.GetNamespace("MAPI")
|
||
|
|
Set fld = nms.GetDefaultFolder(olFolderCalendar)
|
||
|
|
|
||
|
|
' Vi løber kalenderen igennem bagfra (vigtigt ved sletning)
|
||
|
|
For i = fld.Items.Count To 1 Step -1
|
||
|
|
Set itm = fld.Items(i)
|
||
|
|
|
||
|
|
' Tjek om elementet er en kalenderaftale
|
||
|
|
If itm.Class = olAppointment Then
|
||
|
|
' Tjek om kategorien matcher (uafhængig af store/små bogstaver)
|
||
|
|
If InStr(1, itm.Categories, kategoriNavn, vbTextCompare) > 0 Then
|
||
|
|
itm.Delete
|
||
|
|
sletAntal = sletAntal + 1
|
||
|
|
End If
|
||
|
|
End If
|
||
|
|
Next i
|
||
|
|
|
||
|
|
' Statusbesked til brugeren
|
||
|
|
MsgBox "Færdig! Der blev slettet " & sletAntal & " begivenheder med kategorien '" & kategoriNavn & "'.", _
|
||
|
|
vbInformation, "Status"
|
||
|
|
|
||
|
|
' Åbn import-vinduet
|
||
|
|
On Error Resume Next
|
||
|
|
Application.ActiveExplorer.CommandBars.ExecuteMso "ImportExport"
|
||
|
|
|
||
|
|
' Hvis ovenstående fejler (fejl 438), så giv besked i stedet for at gå ned
|
||
|
|
If Err.Number <> 0 Then
|
||
|
|
MsgBox "Sletning gennemført, men import-vinduet kunne ikke åbnes automatisk." & vbCrLf & _
|
||
|
|
"Gå til Filer -> Åbn og eksportér -> Importér for at vælge din nye fil.", vbExclamation
|
||
|
|
End If
|
||
|
|
On Error GoTo 0
|
||
|
|
|
||
|
|
End Sub
|