Mail verzenden met knop

[kloosterofobie]

Ik ben bezig met de tool van Ron de Bruin om een excelbestand te verzenden vanuit Excel.

De tool werkt goed alleen ik wil wat kleine dingen aanpassen. In mijn excel bestand moet men hun naam invullen. Nu wil ik de naam terug laten komen in het excelbestand.

Ben zelf al een beetje wezen kijken en proberen maar kom er niet uit.

Het gaat fout bij het rode deel
Sub Mail_Workbook_2()
'Working in 2000-2007
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String

Set wb1 = ActiveWorkbook

If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If

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

'Make a copy of the file/Open it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "& wb1.Name & Sheets("Blad1").Range("C7") & " " & Format(Now, "dd-mmm-yy")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

With wb2
On Error Resume Next
.SendMail "jeroen.klooster@quicknet.nl", _
"Inschrijving EK Pool 2008"
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file
Kill TempFilePath & TempFileName & FileExtStr

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

Heeft iemand een oplossing??

 

[arafy]

TempFileName = [COLOR="Red"]"[/COLOR]& wb1.Name & Sheets("Blad1").Range("C7") & " " & Format(Now, "dd-mmm-yy")

zo op het eerste zicht zou ik zeggen dat er een deel niet staat. nu staat er 1 enkele dubbelqoute.

steven

 

[Hof1607]

re opslaan workbook en mail workbook

Beste Kloosterofobie

ik gebruik bijgaande code en die werkt wel, is weliswaar voor 1 workbook maar toch
is trouwens niet mijn eigen code maar heb deze naar mijn believen aangepast

suc6 Willem

Sub FileOpslaan_Wrkbk()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
    
    'Opslaan file op programshare
    Opslaan_file = "C:\Temp\Te Printen en Verzenden aantallen" & Range("D8").Value & ".xls"
    'Opslaan_file = "C:\Temp\Te Printen en Verzenden aantallen" & Range("D8").Value & ".xls"
    ActiveWorkbook.SaveAs Filename:=Opslaan_file
    
    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
 
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With
 
    '    'Change all cells in the worksheet to values if you want
   With Destwb.Sheets(1).UsedRange
   .Cells.Copy
   .Cells.PasteSpecial xlPasteValues
   .Cells(1).Select
   End With
   Application.CutCopyMode = False
 
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & ""
    TempFileName = "Formulier" & Sourcewb.Name & " "
 
    Onderwerp = ActiveSheet.Name & " " & Range("D8").Value
    Emailadres = "test@test.nl"
    
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail Emailadres, Onderwerp
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    'geef melding weer
    MsgBox "File is per email verzonden aan: " & Emailadres & " en tevens opgeslagen op locatie: " & Opslaan_file
    
End Sub

 

[kloosterofobie]

Bedankt voor jullie reacties. Het mailen lukt tot op zekere hoogte.

Ik kan verzenden en hij komt in mijn outbox maar ik kan hem niet ontvangen omdat de bestandsnaam .xls .xls wordt en mijn virusscanner van mijn provider denkt dat het een verborgen extensie is.

Ik heb al geprobeerd de code te veranderen maar ik kan de "vinger" niet op de zere plek leggen, iemand een suggestie??

Sub CommandButton1_Click()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set Sourcewb = ActiveWorkbook
    
    'Opslaan file op programshare
    Opslaan_file = "C:\EK Pool 2008 " & Range("B7").Value & ""
    'Opslaan_file = "C:\Temp\Te Printen en Verzenden aantallen" & Range("D8").Value & ".xls"
    ActiveWorkbook.SaveAs Filename:=Opslaan_file
    
    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
 
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With
 
    '    'Change all cells in the worksheet to values if you want
   With Destwb.Sheets(1).UsedRange
   .Cells.Copy
   .Cells.PasteSpecial xlPasteValues
   .Cells(1).Select
   End With
   Application.CutCopyMode = False
 
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("Inschrijving ") & ""
    TempFileName = Sourcewb.Name & " "
 
    Onderwerp = "Inschrijving EK Pool 2008 " & Range("B7").Value
    Emailadres = "jeroen.klooster@quicknet.nl"
    
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail Emailadres, Onderwerp
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    'geef melding weer
    MsgBox "Je inschrijving is per email verzonden aan " & Emailadres & " en tevens opgeslagen op locatie: " & Opslaan_file & vbCrLf & "Je krijgt een bevestiging als je inschrijving is ontvangen."
    
End Sub