이메일 여러 범위를 첨부파일로부터 VB 코드

0

질문

내가 사용한 어떤 표준 코드를 인터넷에서 사용하는 버튼을 만들어 이메일에 Outlook 첨부 파일이 있는 범위에서 워크시트가 버튼을 눌렀습니다.코드는 아름답게 작동합니다. 할 수 있는 방법을 확장 코드를 연결하는 두 개 이상의 범위는? 아래 코드에서는 내가 이미 시작 초기화 번째 소스 및 대상이지만,그런 자신감을 잃는 방법에 대한 이 적용되어야 합니다.

Private Sub CommandButton2_Click()

    Dim Source As Range
    Dim Source2 As Range
    Dim Dest As Workbook
    Dim Dest2 As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim AutoPrint As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    Set Source2 = Nothing
    On Error Resume Next
    Set Source = Range("A1:M47").SpecialCells(xlCellTypeVisible)
    Set Source2 = Range("AB1:AN47").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Set Dest2 = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    
    If Range("AC6") <> "" Then
    Source2.Copy
    With Dest2.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    End If

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    AutoPrint = Range("Y6").Value

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = Range("S6").Value
            .CC = Range("S3").Value
            If Range("T3").Value = "Enter bcc addresses manually here" Then
            .bcc = ""
            Else
            .bcc = Range("T3").Value
            End If
            .Subject = Range("V6").Value
            .Body = Range("U6").Value
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            If AutoPrint = "Yes" Then
            .Send   'or use .Display
            Else
            .Display
            End If
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub
attachment excel outlook range
2021-11-23 18:53:40
1

최고의 응답

1

다음과 같은 내에서 위의 의견:

Private Sub CommandButton2_Click()
    Dim OutApp As Object, AutoPrint
    Dim colAttachments As New Collection, fPath As String, ws As Worksheet, tm, p
    
    Set ws = ActiveSheet
    tm = Format(Now, "dd-mmm-yy h-mm-ss")
    
    'first attachment
    fPath = CreateAttachment(ws.Range("A1:M47"), _
                            "Selection1 of " & ws.Parent.Name & " " & tm)
    If Len(fPath) = 0 Then Exit Sub 'exit if there was a problem
    colAttachments.Add fPath
    
    If ws.Range("AC6") <> "" Then    'second attachment? Note the filename needs to be distinct...
        fPath = CreateAttachment(ws.Range("AB1:AN47"), _
                                 "Selection2 of " & ws.Parent.Name & " " & tm)
        If Len(fPath) = 0 Then Exit Sub 'exit if there was a problem
        colAttachments.Add fPath
    End If
        
    Set OutApp = CreateObject("Outlook.Application")
    AutoPrint = ws.Range("Y6").Value
    With OutApp.CreateItem(0)
        .to = ws.Range("S6").Value
        .CC = ws.Range("S3").Value
        If ws.Range("T3").Value = "Enter bcc addresses manually here" Then
            .bcc = ""
        Else
            .bcc = ws.Range("T3").Value
        End If
        .Subject = ws.Range("V6").Value
        .Body = ws.Range("U6").Value
        For Each p In colAttachments  'add each attachment from the collection
            .Attachments.Add p
            Kill p
        Next p
        If AutoPrint = "Yes" Then
            .Send
        Else
            .Display
        End If
    End With
      
End Sub

'create a file from the visible cells in `rng`
'  and return the path to the file
Function CreateAttachment(rng As Range, fName As String) As String
    Dim rngVis As Range, ws As Worksheet, ext, fPath As String
    'try to get a range with only visible cells
    On Error Resume Next
    Set rngVis = rng.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rngVis Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected. " & _
        "Please correct and try again.", vbExclamation + vbOKOnly
    Else
        Application.ScreenUpdating = False
        Set ws = Workbooks.Add(xlWBATWorksheet).Sheets(1)
        rngVis.Copy
        With ws.Cells(1)
            .PasteSpecial Paste:=xlPasteColumnWidths '8
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            .Select
        End With
        Application.CutCopyMode = False
        ext = IIf(Val(Application.Version) < 12, ".xls", ".xlsx")
        fPath = Environ$("temp") & "\" & fName & ext
        ws.Parent.SaveAs fPath
        ws.Parent.Close False
        CreateAttachment = fPath
    End If
End Function
2021-11-24 05:51:35

감사합니다 그래서 많이 제공 그래서 많은 세부 사항에서 당신의 대답이다. 정말 기본적인 질문을 첨부 이 코드를 ActiveX 버튼,코드는 것 같이 떨어지는에서 이상의 시작 기능이 있다. 나는 생각에 맞추로만 인식하는 전용 서브/서브 코드,그리고 어떻게든 내가 필요로하는 기능이 결합으로 이? 이 시점에서 나에게 말할 수 없는지 코드가 작동하는지...
Stephen Jay

함수가 호출서 CommandButton2_Click 그래서 당신의 버튼만 호출해야 하는 하위
Tim Williams

참고로"위에 떨어지는"는지 설명-하는 데 문제가 있으면 코드 그것은 항상 정확하게 설명하기 위해 무엇이 일어나고 있습니다. 오류가 발생하면,어떤 오류 메시지와는 라인이 강조되는 경우 당신은"를 클릭 디버"?
Tim Williams

실행하는 경우 디버깅,임시 파일 이름을 얻을 만들어진 정밀한,그리고 나는 런타임 오류'-2147417856(80010100)':자동화 오류 시스템 호출에 실패했습니다. 보이지 않는 행 강조 표시된 때문에 오류가 있습니다. 이 어떤 방법으로는 사실과 연결되어 있는 세 가지 별도의 명령 버튼을 정의됩니까?
Stephen Jay

나의 원래 코드를 생성하는 하나의 부착은 CommandButton2,나는 당신의 코드(와 함께 몇 가지 아주 간단한 변화)에 CommandButton3.
Stephen Jay

시 주석 처리 Kill 라인과 참조하는 경우는 변경이 아무것도. 하지 않을 경우 수 있는 테스트는 조금 나중에.
Tim Williams

같은 오류가 발생...사전에 감사합니다 이것을 찾!
Stephen Jay

은 ActiveX 버튼 워크시트에서?
Tim Williams

다른 언어로

이 페이지는 다른 언어로되어 있습니다

Русский
..................................................................................................................
Italiano
..................................................................................................................
Polski
..................................................................................................................
Română
..................................................................................................................
हिन्दी
..................................................................................................................
Français
..................................................................................................................
Türk
..................................................................................................................
Česk
..................................................................................................................
Português
..................................................................................................................
ไทย
..................................................................................................................
中文
..................................................................................................................
Español
..................................................................................................................
Slovenský
..................................................................................................................