Переименуйте файл Excel и проверьте, существует ли файл в sharepoint через vba - PullRequest
0 голосов
/ 18 июня 2020

Итак, я создаю пользовательскую форму, которую заполняют несколько человек. Общий файл базы данных будет храниться в 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

Хорошо, теперь проблема в том, что это закрывает форму после отображения ошибки, любым способом предотвратить закрытие формы и сохранить все записи заполненными, чтобы пользователь мог попробовать нажать кнопку отправки снова через несколько секунд?

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...