1

Question

我已将这个用于我为工作创作的许多项目。我学到了很多东西，但我正在撞墙。

当我的员工使用保存并作为附件手动通知我和其他部门时，我想要安装宏按钮。如果我将宏按钮安装到工作表中，则需要通过电子邮件将其作为启用宏的工作表进行正确的操作吗？

此外，除了附件部分外，一切似乎都在这个子工作...我希望它继续是通用的，所以任何人都可以使用第二个VBA代码上传

1

    Sub SendReferral()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = "_" & Range("b2").Value & "Services@gmail.com"
        .CC = "myself"
        .BCC = ""
        .Subject = "Referral for " & Range("d2").Value & " - " & Range("f2").Value
        .Body = "Hello, please follow up with the member within 2 business days, thank you."
        .Attachments.Add Application.ActiveWorkbook.FullName
        .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    End Sub

我一直在尝试修改这个，但目前无法通过FilePath行，所以我无法检查Sub的其余部分是否有效。

2

    Sub UploadReferral()
    Dim FilePath As String
    Dim I As Integer, J As Integer
    FilePath = "\\profiler\docs$\Manager Docs\Global Referrals -                 Testing.xlsx"
        If FileAlreadyOpen(FilePath) = True Then
            Application.OnTime Now + TimeValue("00:0:30"), "TransferData"
            Worksheets("Flat File").CommandButton1.Enabled = False
            Worksheets("Flat File").CommandButton1.Caption = "Saving... Please wait"
        Else:
            Workbooks.Open (FilePath)
            With Workbooks("Global Referrals.xlsx").Worksheets("Referrals")
            NewRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            Workbooks("ReferralForm1.xlsm").Activate
            LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            For I = 2 To LastRow
                For J = 1 To 14
                    .Cells(NewRow, J) = Cells(I, J)
                Next J
                .Cells(NewRow, 15) = Environ("UserName")
                NewRow = NewRow + 1
            Next I
            End With
            Worksheets("ReferralForm1").CommandButton1.Enabled = True
            Worksheets("ReferralForm1").CommandButton1.Caption = "Transfer Data"
            Workbooks("Global referrals.xlsx").Close SaveChanges:=True
            MsgBox "Global Referrals updated"
    End If
    End Sub

Answer 1

应该修复附件部分

1

Option Explicit

Sub SendReferral()
    Dim OutlookApp As Object
    Dim OutlookMail As Object


    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .To = "Services@gmail.com " & Range("b2").Value & " Services@gmail.com"
        .CC = "Services@gmail.com "
        .BCC = ""
        .Subject = "Referral for " & Range("d2").Value & " - " & Range("f2").Value
        .Body = "Hello, please follow up with the member within 2 business days, thank you."
         ActiveWorkbook.Save
        .Attachments.Add ActiveWorkbook.FullName
        '.Display '<<<---- use it for editing 
        .Send
    End With

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    End Sub

2

Option Explicit

Public Sub UploadReferral()
    Dim FilePath As String
    Dim NewRow As Long, LastRow As Long
    Dim I As Integer, J As Integer

    FilePath = "\\profiler\docs$\Manager Docs\Global Referrals\Testing.xlsx"

    If FileAlreadyOpen(FilePath) = True Then
        Application.OnTime Now + TimeValue("00:0:30"), "TransferData"
        Worksheets("Flat File").CommandButton1.Enabled = False
        Worksheets("Flat File").CommandButton1.Caption = "Saving... Please wait"
    Else:
        Workbooks.Open (FilePath)
        With Workbooks("Global Referrals.xlsx").Worksheets("Referrals")
        NewRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        Workbooks("ReferralForm1.xlsm").Activate
        LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            For I = 2 To LastRow
                For J = 1 To 14
                    .Cells(NewRow, J) = Cells(I, J)
                Next J
                .Cells(NewRow, 15) = Environ("UserName")
                NewRow = NewRow + 1
            Next I
        End With
        Worksheets("ReferralForm1").CommandButton1.Enabled = True
        Worksheets("ReferralForm1").CommandButton1.Caption = "Transfer Data"
        Workbooks("Global referrals.xlsx").Close SaveChanges:=True
            MsgBox "Global Referrals updated"
    End If
End Sub

Function FileAlreadyOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long

    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0

    Select Case iErr
    Case 0:    FileAlreadyOpen = False
    Case 70:   FileAlreadyOpen = True
    Case Else: Error iErr
    End Select

End Function

宏用于附加带有vba代码的工作表，并编辑工作表以上载到共享的Excel工作表

1

2

1 个答案: