Итак, я создаю пользовательскую форму, которую заполняют несколько человек. Общий файл базы данных будет храниться в Sharepoint. Форма работает отлично только до тех пор, пока 2 человека не нажмут кнопку отправки одновременно.
Чтобы противостоять этому, кто-то предложил мне сделать следующее:
Sub DownloadAndSave()
' In the location in the network folder:
' If a file exists called "MyData_CHECKOUT.xlsm" then
'deny a save
' Else
' RENAME the target file to "MyData_CHECKOUT.xlsm"
' Download "MyData_CHEKOUT.xlsm", make changes, save file to network as "MyData.xlsm"
' Delete the MyData_CHECKOUT.xlsm" file
End Sub
Раньше я использовал сетевой диск, и он работал нормально. Но для sharepoint я не могу найти способ переименовать файл. Я нашел способ удалить файл sharepoint, загрузить и загрузить его. Но я не могу найти ответы, чтобы переименовать файл и проверить, существует ли файл уже в папке sharepoint.
Пожалуйста, помогите, или есть другой способ решить проблему, когда 2 человека отправляют одновременно время, пожалуйста, расскажите мне об этом
Изменить: Полный код, который я использую сейчас, следующий:
Sub Submit()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AutomationSecurity = msoAutomationSecurityLow
If frmForm.txtAE.Value = "" Or frmForm.txtAPL.Value = "" Or frmForm.txtBatches.Value = "" Or frmForm.txtProject.Value = "" Or frmForm.txtQA.Value = "" Or frmForm.txtTeam.Value = "" Or frmForm.cmbDS.Value = "" Or frmForm.cmbPriority.Value = "" Or frmForm.cmbRelease.Value = "" Then
MsgBox ("Complete All fields marked with (*) to proceed")
Else
Dim strFileName As String
Dim strFileExists As String
'Call Downloadtest
strFileName = ""
strFileExists = Dir(strFileName)
If strFileName <> "" Then
MsgBox ("Another user is currently submitting a booking. Please wait for a minute, and then try again.")
Else
Dim nwb As Workbook
Set nwb = Workbooks.Open("sharepoint link")
nwb.Sheets("Sheet1").Unprotect Password:="password"
Dim emptyRow As Long
emptyRow = WorksheetFunction.CountA(nwb.Sheets("Sheet1").Range("A:A")) + 1
Dim arDate As Variant
arDate = Split(frmForm.dtPlanned.Value, "/")
With nwb.Sheets("Sheet1")
.Cells(emptyRow, 1) = emptyRow - 1
.Cells(emptyRow, 2) = Date
.Cells(emptyRow, 3) = frmForm.txtProject.Value
.Cells(emptyRow, 4) = frmForm.txtTeam.Value
.Cells(emptyRow, 5) = frmForm.txtAPL.Value
.Cells(emptyRow, 6) = frmForm.txtQA.Value
.Cells(emptyRow, 7) = frmForm.txtAE.Value
.Cells(emptyRow, 8) = frmForm.cmbRelease.Value
.Cells(emptyRow, 9) = frmForm.cmbDS.Value
.Cells(emptyRow, 10) = frmForm.txtBatches.Value
.Cells(emptyRow, 11) = frmForm.dtReview.Value
.Cells(emptyRow, 12) = frmForm.dtSubmission.Value
.Cells(emptyRow, 13) = frmForm.dtRelease.Value
If frmForm.dtPlanned.Value = "" Then .Cells(emptyRow, 14) = "" Else .Cells(emptyRow, 14) = DateSerial(arDate(2), arDate(1), arDate(0))
.Cells(emptyRow, 15) = frmForm.cmbPriority.Value
.Cells(emptyRow, 16) = "Pending"
.Cells(emptyRow, 17) = frmForm.txtRemarks.Value
.Cells(emptyRow, 18) = Application.UserName
End With
nwb.Sheets("Sheet1").Protect Password:="password"
'nwb.SaveAs ("sharepoint link")
nwb.SaveAs Filename:="sharepoint link"
nwb.Close
'Kill ("C:\Users\username\Downloads\Planning Sheet\KF 6.0_checkout.xlsm")
MsgBox ("Your Entry has been recorded.")
End If
End If
Unload frmForm
End Sub
Извините, код немного беспорядочный, strFileName и strFileexists проверяли существует ли контрольный файл или нет, когда раньше я использовал сетевой диск. Но теперь для sharepoint они не работают, поэтому я заменил их пустой строкой
Я заменил фактические ссылки sharepoint на ссылку sharepoint в коде
Edit2: Я придумал решение чтобы добавить обработчик ошибок, поэтому, когда код не может редактировать файл, потому что его использует кто-то другой, он выдаст ошибку, и обработчик ошибок скажет, что кто-то другой использует файл.
Это мой отредактированный код :
Sub Submit()
On Error GoTo eh
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AutomationSecurity = msoAutomationSecurityLow
If frmForm.txtAE.Value = "" Or frmForm.txtAPL.Value = "" Or frmForm.txtBatches.Value = "" Or frmForm.txtProject.Value = "" Or frmForm.txtQA.Value = "" Or frmForm.txtTeam.Value = "" Or frmForm.cmbDS.Value = "" Or frmForm.cmbPriority.Value = "" Or frmForm.cmbRelease.Value = "" Then
MsgBox ("Complete All fields marked with (*) to proceed")
Else
Dim strFileName As String
Dim strFileExists As String
'Call Downloadtest
strFileName = ""
strFileExists = Dir(strFileName)
If strFileName <> "" Then
MsgBox ("Another user is currently submitting a booking. Please wait for a minute, and then try again.")
Else
Dim nwb As Workbook
Set nwb = Workbooks.Open("sharepoint link")
nwb.Sheets("Sheet1").Unprotect Password:="password"
Dim emptyRow As Long
emptyRow = WorksheetFunction.CountA(nwb.Sheets("Sheet1").Range("A:A")) + 1
Dim arDate As Variant
arDate = Split(frmForm.dtPlanned.Value, "/")
With nwb.Sheets("Sheet1")
.Cells(emptyRow, 1) = emptyRow - 1
.Cells(emptyRow, 2) = Date
.Cells(emptyRow, 3) = frmForm.txtProject.Value
.Cells(emptyRow, 4) = frmForm.txtTeam.Value
.Cells(emptyRow, 5) = frmForm.txtAPL.Value
.Cells(emptyRow, 6) = frmForm.txtQA.Value
.Cells(emptyRow, 7) = frmForm.txtAE.Value
.Cells(emptyRow, 8) = frmForm.cmbRelease.Value
.Cells(emptyRow, 9) = frmForm.cmbDS.Value
.Cells(emptyRow, 10) = frmForm.txtBatches.Value
.Cells(emptyRow, 11) = frmForm.dtReview.Value
.Cells(emptyRow, 12) = frmForm.dtSubmission.Value
.Cells(emptyRow, 13) = frmForm.dtRelease.Value
If frmForm.dtPlanned.Value = "" Then .Cells(emptyRow, 14) = "" Else .Cells(emptyRow, 14) = DateSerial(arDate(2), arDate(1), arDate(0))
.Cells(emptyRow, 15) = frmForm.cmbPriority.Value
.Cells(emptyRow, 16) = "Pending"
.Cells(emptyRow, 17) = frmForm.txtRemarks.Value
.Cells(emptyRow, 18) = Application.UserName
End With
nwb.Sheets("Sheet1").Protect Password:="password"
'nwb.SaveAs ("sharepoint link")
nwb.SaveAs Filename:="sharepoint link"
nwb.Close
'Kill ("C:\Users\username\Downloads\Planning Sheet\KF 6.0_checkout.xlsm")
MsgBox ("Your Entry has been recorded.")
End If
End If
Unload frmForm
eh:
MsgBox("Someone else using the file")
End Sub
Хорошо, теперь проблема в том, что это закрывает форму после отображения ошибки, любым способом предотвратить закрытие формы и сохранить все записи заполненными, чтобы пользователь мог попробовать нажать кнопку отправки снова через несколько секунд?