Hallo Leute,
kann mir jemand helfen ? Den folgenden Code so abändern, dass das ganze mit Lotus notes klappt ?
wäre echt super, wenn jemand ne lösung hätte
Option Explicit
Sub EMailMitDateiSenden()
Dim ol, mail As Object
Dim Mldg, Frage, Frage2, Fehlermeldung, Anhang, Belastungsanzeige, Name As String
Dim ws1 As Worksheet, ws2 As Worksheet
Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(0)
Set ws1 = ActiveSheet
Set ws2 = Worksheets("Fehlermeldung")
'Abfrage ob Daten eingegeben
If ws1.Range("AH12").Value = "-" Or ws1.Range("AH12").Value = "" Then
MsgBox ("Erst Datum eingeben!")
Exit Sub
End If
If ws1.Range("K17").Value = "" Then
MsgBox ("Erst Lieferanten-Nr. eingeben!")
Exit Sub
End If
If ws1.Range("K18").Value = "" Then
MsgBox ("Erst Bestell-Nr. eingeben!")
Exit Sub
End If
If ws1.Range("AB16").Value = "" Then
MsgBox ("Materialnummer eingeben!")
Exit Sub
End If
If ws1.Range("AB19").Value = "" Then
MsgBox ("Erst die Menge der Bestellung eingeben!")
Exit Sub
End If
If ws1.Range("AJ19").Value = "" Then
MsgBox ("Erst die Menge der Fehlerhaften Teile eingeben!")
Exit Sub
End If
'Daten Sichern
'ActiveWorkbook.Save
'Daten komplett?
Frage = MsgBox("Alles richtig?" _
, vbYesNo + vbQuestion, "Das ging aber schnell!", "", 0)
If Frage = vbNo Then Exit Sub
Frage2 = MsgBox("Wirklich...? Lieferanten E-Mailadresse nicht vergessen." _
, vbYesNo + vbQuestion, "Ich frag jetzt nicht nochmal!", "", 0)
If Frage2 = vbNo Then Exit Sub
'Druckabfrage
Mldg = MsgBox("Willst Du das Dokument drucken und zusätzlich als Fax verschicken?" _
, vbYesNo + vbQuestion, "Drucken für FAX ?", "", 0)
If Mldg = 6 Then ActiveSheet.PrintOut
'Blattschutz aufheben
ActiveSheet.Unprotect
ActiveWorkbook.Sheets(Array("Fehlermeldung")).Copy
'Sub CodeHinterTabelleLoeschen()
'If MsgBox("Ok, Code hinter der Aktuellen Tabelle löschen?", _
' vbQuestion + vbYesNo, "Aktuelle Tabelle") = vbYes Then
Dim ws As Worksheet
Set ws = ActiveSheet
With ActiveWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With
'End If
'End Sub
'Verknüpfung als Wert schreiben
Dim c As Range
'Dim frage
For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
If InStr(1, c.Formula, "xls]") <> 0 Then
c.Select
c.Value = c.Text
Else
c.Value = ""
End If
Next
'Blattschutz aufheben
ActiveSheet.Unprotect
'Button löschen
ActiveSheet.Shapes("E-Mail").Delete
ActiveSheet.Shapes("Speichern").Delete
ActiveSheet.Shapes("neueAWM").Delete
ActiveSheet.Shapes("de").Delete
ActiveSheet.Shapes("en").Delete
ActiveSheet.Shapes("def").Delete
ActiveSheet.Shapes("enf").Delete
'Verknüpfungen und Formeln löschen
'ActiveSheet.Range("A1:A2,H58:H60,Q58:Q60,X58:X60").Select
'Selection.ClearContents
'Fixierung aufheben
ActiveWindow.FreezePanes = False
'Alle Zellen auf gesperrt setzen
Cells.Select
Selection.Locked = True
Selection.FormulaHidden = False
Range("A1").Select
'Blattschutz aktivieren
ActiveSheet.Protect
'Namen der Austauscharbeitsmappe festlegen
Fehlermeldung = ["ABWEICHMELDUNG"&"_"&N9&"_"] & Date
Name = [K12]
If Fehlermeldung <> "" Then
ActiveWorkbook.SaveAs Filename:="C:\QM2\" & Fehlermeldung & ".xls", FileFormat:=xlNormal
'Betreff aus Zelle K11 und K13
mail.Subject = ["ABWEICHMELDUNG"&"_"& N9 &"_"& AB16 &"_"& AB17]
ActiveWorkbook.Close
End If
'Mail Senden an
mail.To = [H58] & ";" & [H59] & ";" & [H60] & ";" & [Q58] & ";" & [Q59] & ";" & [Q60] & ";" & [X58] & ";" & [X59] & ";" & [X60]
'mail.cc = "indy2000@t-online.de"
'mail.bcc = "indy2000@t-online.de"
'mit body wird nur noch im txt-Format versandt!
mail.body = "Guten Tag," & Chr(13) & Chr(13) & _
"diese E-Mail wurde direkt aus Excel versandt:" & Chr(13) & _
"this E-Mail was dispatched directly from Excel:" & Chr(13) & _
Fehlermeldung & Chr(13) & Chr(13) & _
"und dabei die nachfolgende Datei angehängt:" & Chr(13) & _
"and the following file attached:" & Chr(13) & Chr(13) & _
"Mit freundlichen Grüßen" & Chr(13) & Chr(13) & _
Name & Chr(13) & Chr(13)
mail.Attachments.Add "C:\QM2\" & Fehlermeldung & ".xls"
'Anhang anfügen
Frage = MsgBox("Anhang senden?" _
, vbYesNo + vbQuestion, "Anhang senden?", "", 0)
If Frage = vbNo Then GoTo Belastung
ActiveWorkbook.Sheets(Array("Anhang")).Copy
'Blattschutz aufheben
ActiveSheet.Unprotect
Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes("Anhang").Delete
'Fixierung aufheben
ActiveWindow.FreezePanes = False
'Namen der 2 Austauscharbeitsmappe festlegen
Anhang = ["Anhang zur AWM_"& A1]
If Anhang <> "" Then
ActiveWorkbook.SaveAs Filename:="C:\QM\" & Anhang & ".xls", FileFormat:=xlNormal
ActiveWorkbook.SaveAs Filename:="C:\QM2\" & Anhang & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
mail.Attachments.Add "C:\QM2\" & Anhang & ".xls"
Kill "C:\QM2\" & Anhang & ".xls"
End If
Belastung:
'Belastungsanzeige anfügen
Frage = MsgBox("Belastungsanzeige senden?" _
, vbYesNo + vbQuestion, "Anhang senden?", "", 0)
If Frage = vbNo Then GoTo ende
ActiveWorkbook.Sheets(Array("Belastungsanzeige")).Copy
'Blattschutz aufheben
ActiveSheet.Unprotect
Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F25:F37").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues ' Werte
Range("A1").Select
ActiveSheet.Shapes("Anhang").Delete
'Fixierung aufheben
ActiveWindow.FreezePanes = False
'Namen der 2 Austauscharbeitsmappe festlegen
Belastungsanzeige = ["Belastungsanzeige zur AWM_"& A1]
If Belastungsanzeige <> "" Then
ActiveWorkbook.SaveAs Filename:="C:\QM\" & Belastungsanzeige & ".xls", FileFormat:=xlNormal
ActiveWorkbook.SaveAs Filename:="C:\QM2\" & Belastungsanzeige & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
mail.Attachments.Add "C:\QM2\" & Belastungsanzeige & ".xls"
Kill "C:\QM2\" & Belastungsanzeige & ".xls"
ende:
'Mail anzeigen
mail.Display
'mit dem folgenden Befehl kann direkt gesendet werden:
'mail.send
Kill "C:\QM2\" & Fehlermeldung & ".xls"
Else
MsgBox "Es wurde kein Name für die Arbeitsmappe definiert"
End If
End Sub
danke schon mal |