AW: Mail zurück an Absender
19.07.2005 09:34:33
marcl
Hallo Alex,
das in ien Modul:
Option Explicit
Public senden As String
Private Declare
Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal szClass$, ByVal szTitle$) As Long
Public ausstieg As String
Sub emailalle()
' Modul aufrufen um zu prüfen, ob Outlook läuft
Application.Run ("Outlook_offen")
If ausstieg = "ja" Then Exit Sub
' Variablen deklarieren
Dim adresse
Dim nam
Dim blattname As String
Dim nachricht, anfzeile, tz, tabname, dateiname, stammwert, tabzahl, neuname, neuemappe, laaname, pfadname, pruefen
Dim nachricht1
Dim stat
Dim Frage
' Bestätigungen ausschalten
Application.DisplayAlerts = False
' variablen auslesen und festlegen
nam = ActiveSheet.Name
adresse = "Deine Adresse" ' hier Deine Meiladresse eintragen
'Sheets(stat).Select
pfadname = "C:\tmp\" & nam & ".xls"
' neue Arbeitsmappe anlegen mit den Statistiknamen und Berichtsmonat anlegen und speichern
Set neuemappe = Workbooks.Add
With neuemappe
.SaveAs Filename:=pfadname
End With
' zur orginalmappe wechseln und die Meldung in die neu erzeugte Mappe kopieren, vor Tabelle 1
ThisWorkbook.Activate
Sheets(nam).Select
Sheets(nam).Copy Before:=Workbooks(nam & ".xls").Sheets(1)
' Inhalte der Zellen kopieren und nur die Werte wieder einfügen, Leertabellen löschen
Cells.Select
Selection.Copy
Range("A1").Select
Application.CutCopyMode = False
Range("A1").Select
' Tabellenname ergänzen
neuname = nam
ActiveSheet.Name = neuname
' Leertabellen löschen
tabzahl = Sheets.Count
stammwert = 1
For tz = stammwert To tabzahl
If tabzahl = stammwert Then Exit For
If tz = tabzahl Then Exit For
tabname = "Tabelle" & tz
Sheets(Array(tabname)).Select
ActiveWindow.SelectedSheets.Delete
Next
' Modul aufrufen zum löschen der mit Makros belegten Buttons
' ActiveSheet.Shapes.SelectAll
' Selection.Delete
' Cells.Select
' Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Range("A1").Select
' Meldung als E-Mail versenden
ActiveWorkbook.SendMail Recipients:=adresse, Subject:=nam
With ActiveWorkbook
.SaveAs Filename:=pfadname
End With
' Druckfrage
Frage = MsgBox("1 Exemplar drucken?", vbOKCancel)
If Frage = 2 Then GoTo weiter
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
GoTo weiter
Exit Sub
weiter:
' Das neu erzeugte Meldungsfenster schliessen und anschließend aus dem Verzeichnis löschen
ActiveWindow.Close
On Error Resume Next
Kill (pfadname)
Application.StatusBar = "Die Meldung wurde versandt."
Application.DisplayAlerts = False
' Datei speichern
ActiveWorkbook.Save
Application.DisplayAlerts = True
Exit Sub
abbruch:
MsgBox ("Die Meldung wurde nicht versandt !!")
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub
und da sin ein anderes:
Private Declare
Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal szClass$, ByVal szTitle$) As Long
Public ausstieg As String
Sub Outlook_offen()
Dim outlookpruef, ergebnis
ausstieg = ""
On Error GoTo outlookfehler
' Prüfen ob Outlook gestartet ist
hFenster = FindWindow(vbNullString, "Microsoft Outlook")
If hFenster = 0 Then GoTo outlookfehler
If hFenster <> 0 Then Exit Sub
' Outlokk läuft nicht, dann Frage ob Outlook gestartet werden soll
outlookfehler:
outlookpruef = MsgBox("Microsoft Outlook wurde noch nicht gestartet !!!!!" & (Chr(10) & Chr(10)) & "Bitte starten Sie Outlook und versuchen es dann noch einmal.", vbOKOnly)
ausstieg = "ja"
Exit Sub
outlooklaeuft:
' MsgBox ("Outlook läuft")
End Sub
Gruß
marcl