Я боролся за автоматическое добавление встреч в календарь sharepoint в моем мировоззрении. Я смог сделать все, что захочу, за исключением того, что он добавляет встречу в мой календарь по умолчанию. Я включил функцию GetFolderPath, но она ничего не исправляет. После удаления из него средства устранения ошибок я получаю следующее:
Объект не поддерживает это свойство или метод для этой строки.
Set oFolder = Application.Session.Folders.Item (FoldersArray (0))
Здесь все работает, кроме функции GetFolderPath. Я просматривал всю сеть в течение нескольких дней и не могу найти объяснения. Любая помощь будет принята с благодарностью!
По-видимому, я также изо всех сил стараюсь, чтобы код выглядел правильно, используя форматирование здесь. Мои извинения
полный код '' '
Sub UpdateButton_Click()
Dim rng As Range
Result = MsgBox("Are you sure you want to update the team?", vbOKCancel)
If Result = vbCancel Then
Exit Sub
End If
ActiveWorkbook.Save
Set rng = Nothing
Set rng = ActiveSheet.Range("A1:S42")
With CreateObject("Outlook.Application").CreateItem(olMailItem)
.Subject = "Next Pending Calgary Bulk Update & Fill Request"
.Recipients.Add "myemail"
.htmlBody = RangetoHTML(rng)
.send
End With
End Sub
Sub SendButton_Click()
Dim rng As Range
Dim strfilename As String
Dim strFileExists As String
Dim strbody As String
Dim strsubject As String
Dim y As String
Dim m As String
Dim d As String
Dim OrderDate As Date
Dim n As Integer
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim objFolder As Outlook.folder
Worksheets("Bulk").Activate
Set rng = Nothing
Set rng = ActiveSheet.Range("A1:S42")
OrderDate = Worksheets("Bulk").Range("J3").Value
y = DatePart("yyyy", OrderDate)
m = DatePart("m", OrderDate)
d = DatePart("d", OrderDate)
If m < 10 Then
m = "0" & m
End If
If d < 10 Then
d = "0" & d
End If
If ActiveSheet.Range("J3") = "" Then
MsgBox "Please enter a requested delivery date at least 3 weeks from
today in cell J3"
Exit Sub
End If
If ActiveSheet.Range("B2") = "" Then
MsgBox "Please enter your name in cell B2"
Exit Sub
End If
If ActiveSheet.Range("D41") = "" Then
MsgBox "Please Enter Meeting Place & Contact Info"
Exit Sub
End If
If ActiveSheet.Range("B3") = "" Then
ActiveSheet.Range("B3") = Date
End If
If ActiveSheet.Range("L39") < "30000" Then
Result = MsgBox("Bulk order is less than 30,000 Liters. Are you sure you
want to proceed?", vbYesNo)
If Result = vbNo Then
Exit Sub
End If
End If
n = 1
strfilename = "C:\Users\" & Environ$("Username") & "\Ecolab\Esau, Rob - BC
Inventory\Bulk Orders etc\Ordered Loads\" & y & "\" & y & "-" & m & "-" & d &
" Bulk Order.xlsm"
strFileExists = Dir(strfilename)
If strFileExists <> "" Then
strfilename = "C:\Users\" & Environ$("Username") & "\Ecolab\Esau, Rob -
BC Inventory\Bulk Orders etc\Ordered Loads\" & y & "\" & y & "-" & m & "-" &
d & " Bulk Order" & n & ".xlsm"
strFileExists = Dir(strfilename)
If strFileExists <> "" Then
Do Until strFileExists = ""
n = n + 1
strfilename = "C:\Users\" & Environ$("Username") & "\Company\BC
Inventory\Bulk Orders etc\Ordered Loads\" & y & "\" & y & "-" & m &
"-" & d & " Bulk Order" & n & ".xlsm"
strFileExists = Dir(strfilename)
Loop
End If
End If
Result = MsgBox("Are you sure you want to save & send to " & strfilename,
vbOKCancel)
If Result = vbCancel Then
Exit Sub
End If
'ActiveWorkbook.SaveCopyAs strfilename
Set olApp = GetObject("", "Outlook.Application")
Set objns = Outlook.Application.GetNamespace("MAPI")
Set objFolder = GetFolderPath("SharePoint Lists\calendar name")
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
Set olAppItem = olApp.CreateItem(olAppointmentItem)
With olAppItem
.Subject = "Incoming Bulk"
.Start = OrderDate
'.attachments.Add strfilename
.alldayevent = True
.Save
End With
Set olAppItem = Nothing
Set olApp = Nothing
'Worksheets("Bulk").Range("B3:C3").ClearContents
'Worksheets("Bulk").Range("B2:C2").ClearContents
'Worksheets("Bulk").Range("J3:K3").ClearContents
'Worksheets("Bulk").Range("C5:F38").ClearContents
'Worksheets("Bulk").Range("I5:I38").ClearContents
'Worksheets("Bulk").Range("L5:N38").ClearContents
'Worksheets("Bulk").Range("S5:S38").ClearContents
'Worksheets("bulk").Range("D41:R42").ClearContents
'ActiveWorkbook.Save
strbody = "Hello," & vbNewLine & vbNewLine & _
"Please see the attached bulk order form with requested delivery
date of " & m & "-" & d & vbNewLine & vbNewLine & _
"Thanks"
strsubject = y & "-" & m & "-" & d & " Bulk Order"
'With CreateObject("Outlook.Application").CreateItem(olMailItem)
'.Subject = strsubject
'.Recipients.Add "Myemail"
'.Body = strbody
'.attachments.Add strFileName
'.send
'End With
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim tempfile As String
Dim tempwb As Workbook
tempfile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set tempwb = Workbooks.Add(1)
With tempwb.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With tempwb.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=tempfile, _
Sheet:=tempwb.Sheets(1).Name, _
Source:=tempwb.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.Filesystemobject")
Set ts = fso.getfile(tempfile).openastextstream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
tempwb.Close savechanges:=False
Kill tempfile
Set ts = Nothing
Set fso = Nothing
Set tempwb = Nothing
End Function
Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
Dim oFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
'On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
' ''