2009-09-28 5 views
0

J'utilise Excel 2003 et j'ai du mal à attacher des cellules sur le corps d'un email. J'ai reçu une partie du code http://www.rondebruin.nl/mail/folder3/mail4.htm mais ça ne marche pas pour moi. Ce qui m'arrive, c'est qu'une feuille de calcul apparaîtrait sur laquelle il n'y aurait pas d'examen par les pairs et un message d'erreur disant "erreur d'exécution '1004' La méthode PasteSpecial de la classe Range a échoué". S'il vous plaît fournir une assistance.VBA-Problème avec l'attachement des cellules dans le corps de l'email (Outlook)

Voici le code (le code en gras est l'erreur):

'' Creates Email 

Sub Email_Click() 
Dim sDate As Date 
sDate = ThisWorkbook.Sheets("SheetA").Range("H4").Value 

Dim olApp As Outlook.Application 
Dim olMail As MailItem 
Dim tmp 
Set olApp = New Outlook.Application 

'' Location of email template 
Set olMail = olApp.CreateItem(olMailItem) 
ThisWorkbook.Worksheets("SheetB").Activate 
Application.ActiveSheet.Columns("A:E").AutoFit 

Dim totalRows As Integer 
totalRows = Application.ActiveSheet.UsedRange.Rows.count 

With olMail 
'' Subject 
.Subject = "Email" 
.BodyFormat = olFormatHTML 
.To = "[email protected]" 

'' Body 
.HTMLBody = RangetoHTML(Application.ActiveSheet.Range("A1:E" & totalRows)) 
.Display 

End With 
Set olMail = Nothing 
Set olApp = Nothing 
ThisWorkbook.Worksheets("Base Sheet").Activate 

End Sub 



Function RangetoHTML(rng As Range) 
'' Changed by Ron de Bruin 28-Oct-2006 
'' Working in Office 2000-2007 
Dim fso As Object 
Dim ts As Object 
Dim TempFile As String 
Dim TempWB As Workbook 

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".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 
ts.Close 
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ 
"align=left x:publishsource=") 

''Close TempWB 
TempWB.Close savechanges:=False 
''Delete the htm file we used in this function 
Kill TempFile 
Set ts = Nothing 
Set fso = Nothing 
Set TempWB = Nothing 

End Function 
+0

S'il vous plaît votre code en retrait d'au moins 4 caractères de l'espace pour le sélectionner. C'est presque illisible de cette façon. Je ne peux pas l'éditer ... – Atmocreations

+0

La syntaxe semble un peu étrange par rapport à la documentation, mais comme c'est une erreur d'exécution je suppose que ce n'est pas seulement ça. Mais FWIW je m'attendais à ce que la ligne en surbrillance ressembler plus: .Cells (1) .PasteSpecial Paste: = 8, Opération: = xlPasteValues, SkipBlanks: = False, Transpose: = Faux – Mikeb

+0

déboguer votre code étape par étape par ajouter un point d'arrêt. Vous devriez vérifier si TempWB.Sheets (1) retourne vraiment un objet. Il est dangereux de supposer cela quand même – Atmocreations

Répondre

1

Remplacer la ligne erronous

.Cells(1).PasteSpecial Paste:=8 

avec

.Cells(1).PasteSpecial xlPasteColumnWidths, xlPasteSpecialOperationNone, False, False 

Une autre possibilité serait d'écrire votre propre code générant le code html, il est assez facile:

Public Sub 
    Dim crtRow as Integer 
    Dim crtCol as Integer 

    Dim tempBody as String 
    tempBody = "<table>" & vbNewline 
    For crtRow = 0 To maxRow 
     tempBody = tempBody & " <tr>" & vbNewline 
     For crtCol = 0 To maxCol 
      tempBody = tempBody & " <td>" & yourWorksheet.Cells(maxRow, maxCol).Value & "</td>" & vbNewline 
     Next crtCol 
     tempBody = tempBody & " </tr>" & vbNewline 
    Next crtRow 
    tempBody = "</table>" & vbNewline 

    yourEmail.HTMLBody = tempBody 
End Sub 

Bien sûr, le format est pas copié cette façon. Vous devrez l'ajouter vous-même. Et le reste de votre message électronique doit également être construit.

espoir qui aide un peu à

ce qui a trait

+0

Quand j'ai essayé la première méthode, excel me donne une erreur de compilation: erreur de syntaxe. Et je ne suis pas sûr de savoir comment intégrer la deuxième méthode dans les codes. – Anna

+0

bien la raison en est que je l'ai mal écrit. Maintenant, c'est correct, le "Coller: = 8" doit être _removed_. désolé et salutations – Atmocreations

+0

j'ai essayé le nouveau code mais j'obtiens toujours le message d'erreur "erreur d'exécution '1004' méthode PasteSpecial de classe de classe a échoué" avec le nouveau code en surbrillance. – Anna

0

Que diriez-vous:

s = RangetoHTML(Application.ActiveSheet.Name & "$" & "A1:E" & totalRows) 

Function RangetoHTML(rng As String) 
''Reference: Microsoft ActiveX Data Objects x.x Library 
Dim cn As New ADODB.Connection 
Dim rs As New ADODB.Recordset 

strFile = Workbooks(1).FullName 
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _ 
    & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";" 

cn.Open strCon 

rs.Open "SELECT * FROM [" & rng & "]", cn 

s = "<table border=""1"" width=""100%""><tr><td>" 

s = s & rs.GetString(, , "</td><td>", "</td></tr><tr><td>", "&nbsp;") 
s = s & "</td></tr></table>" 

RangetoHTML = s 

rs.Close 
cn.Close 
Set rs = Nothing 
Set cn = Nothing 
End Function 
Questions connexes