danny147
Terugkerende gebruiker
- Lid geworden
- 29 apr 2007
- Berichten
- 4.744
Beste helpers,
Bedankt voor de reacties die ik thuis heb gekregen van o.a. Warme bakkertje, cow18 en Trucker10.
Ik heb gekozen voor de code van Warme bakkertje omdat deze meer variabel is.
De code van Cow18 was ook in orde met hier en daar wat meldingen als het fout ging.
Trucker10 voor de tips en assistentie.
Zie hier de code :
Groetjes Danny. :thumb:
Bedankt voor de reacties die ik thuis heb gekregen van o.a. Warme bakkertje, cow18 en Trucker10.
Ik heb gekozen voor de code van Warme bakkertje omdat deze meer variabel is.
De code van Cow18 was ook in orde met hier en daar wat meldingen als het fout ging.
Trucker10 voor de tips en assistentie.
Zie hier de code :
Code:
Sub Mail_Sheets()
'Working in 97-2010
Dim FileExtStr As String, FileFormatNum As Long
Dim Sourcewb As Workbook, Destwb As Workbook
Dim TempFilePath As String, TempFileName As String
Dim sh As Worksheet, I As Long, strto As String
Dim TheActiveWindow As Window, TempWindow As Window
Dim shtArray(), X As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
Set Sourcewb = ActiveWorkbook
On Error Resume Next
'For Each cell In ThisWorkbook.Sheets("Blad1") _
.Range("A1:A10").Cells.SpecialCells(xlCellTypeConstants)
For Each cell In ThisWorkbook.Sheets("E-mailadressen") _
.Range("A1:A10").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
On Error GoTo 0
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
sq = Sheets("E-mailadressen").Range("C2:C" & Sheets("E-mailadressen").Range("C20").End(xlUp).Row)
For X = 1 To UBound(sq)
Sheets(sq(X, 1)).Copy Before:=Sheets(1)
With ActiveSheet
.Unprotect
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
.Protect
End With
Next
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
For Each ws In .Worksheets
If Right(ws.Name, 3) = "(2)" Then
intA = intA + 1
ReDim Preserve shtArray(intA)
shtArray(intA) = ws.Name
End If
Next ws
.Sheets(shtArray).Copy
End With
'Close temporary Window
TempWindow.Close
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-2010, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an 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
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Overzicht TOUR de FRANCE " & Format(Now, "dd-mmm-yy")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = strto
.CC = ""
.BCC = ""
.Subject = "Overzicht TOUR de FRANCE " & Format(Now, "yyyy")
.Body = "Wijzig indien nodig deze boodschap"
.Attachments.Add (TempFilePath & TempFileName & FileExtStr)
'.Send
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Sheets(shtArray).Delete
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Groetjes Danny. :thumb: