diff --git a/VBA2 b/VBA2 new file mode 100644 index 0000000..5f88392 --- /dev/null +++ b/VBA2 @@ -0,0 +1,53 @@ +Sub SletAltiplanOgFriBegivenheder() + Dim nms As NameSpace + Dim fld As Folder + Dim itm As Object + Dim i As Long + Dim kategori1 As String + Dim kategori2 As String + Dim sletAntal As Long + Dim svar As VbMsgBoxResult + + ' Definition af kategorierne + kategori1 = "Fra Altiplan" + kategori2 = "Fri" + sletAntal = 0 + + ' Sikkerhedsspørgsmål + svar = MsgBox("Vil du slette alle kalenderbegivenheder med kategorierne '" & kategori1 & "' og '" & kategori2 & "'?", _ + 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 + For i = fld.Items.Count To 1 Step -1 + Set itm = fld.Items(i) + + If itm.Class = olAppointment Then + ' Tjek om enten kategori 1 ELLER kategori 2 findes i begivenheden + If InStr(1, itm.Categories, kategori1, vbTextCompare) > 0 Or _ + InStr(1, itm.Categories, kategori2, vbTextCompare) > 0 Then + + itm.Delete + sletAntal = sletAntal + 1 + End If + End If + Next i + + ' Statusbesked + MsgBox "Færdig! Der blev slettet " & sletAntal & " begivenheder i alt.", _ + vbInformation, "Status" + + ' Åbn import-vinduet med fejlhåndtering (som før) + On Error Resume Next + Application.ActiveExplorer.CommandBars.ExecuteMso "ImportExport" + + If Err.Number <> 0 Then + MsgBox "Sletning gennemført, men import-vinduet skal åbnes manuelt via Filer -> Åbn og eksportér.", vbExclamation + End If + On Error GoTo 0 + +End Sub \ No newline at end of file