AW: Tabelle in Intervallen per Mail verschicken
22.12.2009 20:59:42
Josef
Hallo Uni,
nein so funktioniert das nicht.
Ich würde die OnTime Makros belassen, außer der Zeitanpassung, und die Zeit in der gesendet wird
im Makro zum versenden der Mail einbauen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public dblNextRunTime As Double
Public Const cstrProzedure = "sendSheet"
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now), 55, 0)
Application.OnTime earliesttime:=dblNextRunTime, LatestTime:=dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=dblNextRunTime, _
procedure:=cstrProzedure, schedule:=False
End Sub
Sub sendSheet()
'src:= http://www.rondebruin.nl/mail/folder1/mail2.htm
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, objWb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim strFileName As String, strPath As String
Dim blnWasOpen As Boolean
'Hier die Zeit der ersten und letzten Ausführung eintragen!
If Time >= TimeSerial(8, 55, 0) And Time < TimeSerial(18, 0, 0) Then
strPath = "C:\" 'Pfad zur Datei - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileName = Format(Date, "yyMMdd") & " - Daten.xl*"
strFileName = Dir(strPath & strFileName, vbNormal)
If strFileName <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWb In Application.Workbooks
If objWb.Name = strFileName Then
Set Sourcewb = objWb
blnWasOpen = True
Exit For
End If
Next
If Sourcewb Is Nothing Then Set Sourcewb = Workbooks.Open(strPath & strFileName)
'Copy the sheet to a new workbook
Sourcewb.Sheets("Indeces").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
'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"
GoTo ErrExit
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 = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail "ron@debruin.nl", "This is the Subject line"
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
If Not blnWasOpen Then Sourcewb.Close False
End If
End If
ErrExit:
StartTimer
End Sub
Gruß Sepp