VB Scripts hängt an mehr Zeilen in Excel, obwohl ich einzelne Zeilen Daten von Excel wollen

Ich habe ein Skript, um Mail von Excel über Outlook zu senden. Hier wähle ich eine Zelle aus und kopiere sie als HTML und sende sie an Outlook.VB Scripts hängt an mehr Zeilen in Excel, obwohl ich einzelne Zeilen Daten von Excel wollen

aber hängt in Methode Function RangetoHTML(rng As Range) bei Zeile RangetoHTML = ts.readall wenn nein. der Reihe sind bis 70.

Kann jemand helfen.

Sub Mail_Selection_Range_Outlook_Body() 

    Dim rng As Range 
    Dim OutApp As Object 
    Dim OutMail As Object 

    Set rng = Nothing 
    On Error Resume Next 
    'Only the visible cells in the selection 
    Set rng = Selection.SpecialCells(xlCellTypeVisible) 
    'You can also use a fixed range if you want 
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible) 
    On Error GoTo 0 

    If rng Is Nothing Then 
     MsgBox "The selection is not a range or the sheet is protected" & _ 
       vbNewLine & "please correct and try again.", vbOKOnly 
     Exit Sub 
    End If 

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

    Set OutApp = CreateObject("Outlook.Application") 
    Set OutMail = OutApp.CreateItem(0) 

    On Error Resume Next 
    With OutMail 
     .To = "[email protected]" 
     .BCC = "" 
     .Subject = "Report" & Format(Now, "dd-MM-yyyy") 
     .HTMLBody = RangetoHTML(rng) 
     .Display 'or use .Display .Send 
    End With 
    On Error GoTo 0 

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

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 


Function RangetoHTML(rng As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-2016 
    Dim fso As Object 
    Dim ts As Object 
    Dim TempFile As String 
    Dim TempWB As Workbook 
    Dim SignatureFilePath As String 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 
    SignatureFilePath = "Office.htm" 
    'Copy the range and create a new workbook to past the data in 
    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 

    'Publish the sheet to a htm file 
    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 

    'Read all data from the htm file into RangetoHTML 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 
    RangetoHTML = ts.readall // hangs here 
    ts.Close 
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ 
          "align=left x:publishsource=") 
    RangetoHTML = "<BODY style= color:black;font-size:11.0pt;font-weight:400;font-family:Consolas,monospace>Dear Chetan<p>Please find details<p> </BODY>" & RangetoHTML & "<br><br>" & GetSignature(SignatureFilePath) 
    'Close TempWB 
    TempWB.Close savechanges:=False 
    Debug.Print 
    'Delete the htm file we used in this function 
    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 
    Set TempWB = Nothing 
End Function 

Function GetSignature(fPath As String) As String 
    Dim fso As Object 
    Dim TSet As Object 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2) 
    GetSignature = TSet.readall 
    TSet.Close 
End Function

Quelle

2017-05-18 gladiator

Dies ist nicht [VBScript], noch ist es [Makros]. Das ist [vba], also werde ich deine Tags aktualisieren. – YowE3K

Würde es genügen, den Bereich einfach direkt in den Outlook-E-Mail-Text zu kopieren? –

Alternativ kopieren Sie das Blatt in eine neue Arbeitsmappe und senden Sie das Arbeitsblatt per E-Mail als Anlage? –

Dies wird kopieren & die Auswahl aus Excel in der E-Mail Körper Outlook einfügen, Ihre Standardsignatur zu bewahren (falls vorhanden). Wenn Sie eine andere Signatur vom Speicherort der Datei hinzufügen müssen, benötigen Sie zusätzliche Magie.

With OutMail 
    .To = "[email protected]" 
    .BCC = "" 
    .Subject = "Report" & Format(Now, "dd-MM-yyyy") 
    .Display 'or use .Display .Send 
    Dim wdDoc As Object  '## Word.Document 
    Dim wdRange As Object '## Word.Range 
    Set wdDoc = OutMail.GetInspector.WordEditor 
    Set wdRange = wdDoc.Range(0, 0) 
    wdRange.InsertAfter vbCrLf & vbCrLf 
    'Copy the range in-place 
    rng.Copy 
    wdRange.Paste 
End With

Alternativ können die Daten in ein neues Arbeitsblatt kopieren und als Anhang senden:

Sub SendAsAttachment() 
Dim rng As Range 
Dim newWB As Workbook 
Dim newWS As Worksheet 
On Error Resume Next 
Set rng = Selection.SpecialCells(xlCellTypeVisible) 
If Err.Number <> 0 Then Exit Sub 
On Error GoTo 0 

Set newWB = Workbooks.Add 
With newWB 
    Set newWS = .Sheets(1) 
    newWS.Name = rng.Parent.Name 
    rng.Copy newWS.Range("A1") 
    Do While .Worksheets.Count > 1 
     .Worksheets(.Count).Delete 
    Loop 
    .SendMail "[email protected]", "subject", False 
    .Close False 
End With 
End Sub

Die letztere Methode allerdings nicht Signaturzeile in der E-Mail enthalten.

Quelle

2017-05-18 14:27:54

die erste Methode ist, was ich will, aber es kopiert die ganze Zelle, ich will nur die eine, die ich ausgewählt habe. – gladiator

Sie setzen Ihre Rng-Variable auf ALLE sichtbaren Zellen in der Auswahl. ändere das einfach so: 'Set rng = Selection.Cells (1)'. Dies nimmt nur die erste Zelle in was auch immer ausgewählt ist. –

VB Scripts hängt an mehr Zeilen in Excel, obwohl ich einzelne Zeilen Daten von Excel wollen

Antwort

Verwandte Themen