Private Sub CmdSend_Click()Dim session As Object
Dim db As Object
Dim doc As Object
Dim strTo As Variant
Dim strPath As String
Dim EmbedObj As Object
Dim AttachME As Object
Dim Recipients() As String
Dim Namen As String
Dim NamenNeu As String
Dim j As Integer
strTo = Array(cstrTo, Me.lblUser2.Caption)
'Pfadeingabe zum zwischenspeichern
Do
strPath = InputBox("Please enter a valid pathname" & vbCrLf & "to save the file temporarily:", _
"Save CI", "C:\")
'Falls das letzte Zeichen ein Backslash ist, diesen löschen
If Right(strPath, 1) = "\" Then strPath = Left(strPath, Len(strPath) - 1)
'Prüfen, ob dieser Pfad existiert
If Dir(strPath, vbDirectory) = "" Then Warning = MsgBox("This is no valid path." _
& vbCrLf & "Please check!", vbCritical, "Path not found")
Loop Until Dir(strPath, vbDirectory) <> ""
With Application
.ScreenUpdating = False
.SheetsInNewWorkbook = 2 'Einstellung, dass bei neuer Arbeitsmappe 2 Tabellen vorhanden sind.
End With
Workbooks.Add 'Neue Datei mit 2 Arbeitsmappen erstellen
ActiveWorkbook.SaveAs strPath & "\CI Temp", xlWorkbookNormal 'Arbeitsmappe speichern
Application.SheetsInNewWorkbook = 3 'Zürücksetzen auf 3 Tabellen bei neuer Arbeitsmappe
'Daten in Zeile 1 übertragen
Sheets(1).Name = "Name"
Range("A1").Value = Me.lblCNo.Caption
Range("B1").Value = Me.txtMaterialNo.Value
Range("C1").Value = Me.txtOrderNoCustomer.Value
Range("D1").Value = Me.txtOrderNoCFS.Value
Range("E1").Value = Me.txtAffectedQ.Value & Me.lblAQ.Caption
Range("F1").Value = Me.txtDeliveredQ.Value & Me.lblDQ.Caption
Range("G1").Value = Me.lblUser2.Caption
Range("H1").Value = Me.lblDate2.Caption
Range("I1").Value = Me.txtWeb.Value
Range("J1").Value = Me.txtSBWidth.Value
Range("K1").Value = Me.txtSBlength.Value
Range("L1").Value = Me.txtCosts.Value
Range("M1").Value = Me.txtInspector.Value
Range("N1").Value = Me.txtMatInspDate.Value
Range("O1").Value = Me.txtSample.Value
Range("P1").Value = Me.txtMatSampDate.Value
Range("Q1").Value = Me.cboPSMKempten.Value
Range("R1").Value = Me.txtReason.Value
Range("U1").Value = Me.cboCC.Value
Range("V1").Value = Me.txtCustomerName.Value
Range("W1").Value = Me.txtOrderNoCC.Value
Range("X1").Value = Me.txtPos.Value
Range("Y1").Value = Me.txtMaterialName.Value
Range("Z1").Value = Me.txtPSM.Value
'Nummernzuweisung für Materialart für Statistik der Datenbank
If Me.opt3D = True And Me.optSB = True Then Range("AA1").Value = "1"
If Me.opt3D = True And Me.optConverter = True Then Range("AA1").Value = "2"
If Me.optFF = True Then Range("AA1").Value = "3"
If Me.optXPP = True Then Range("AA1").Value = "4"
Range("AB1").Value = Me.chkMaterialDefect.Value
Range("AC1").Value = Me.chkDelivery.Value
Range("AD1").Value = Me.chkTransport.Value
Range("AE1").Value = Me.chkOthers.Value
Range("AF1").Value = Me.cboTBM.Value
'Chargennummern in 2. Tabellenblatt Spalte A übernehmen
Sheets(2).Name = "Name2"
Sheets(2).Activate
Call Chargennummern(Charge.txtBoxNo.Value & ";")
With Workbooks("CI Temp.xls")
.Save
.Close
End With
'Zweite Arbeitsmappe für Complaint Inquiry als Anhang
With ActiveWorkbook.Sheets("Inquiry")
.Visible = True
.Activate
.Copy
.Visible = xlVeryHidden
End With
With ActiveWorkbook
.SaveAs strPath & "\CI", xlWorkbookNormal
.Close
End With
Application.ScreenUpdating = False
ReDim Recipients(10) 'Empfängerfeld dimensionieren
'PM (Recipients(0)) auswählen
If Me.opt3D = True Then
Recipients(0) = "Name1"
Else
Recipients(0) = "Name2"
End If
'PSM Kempten als Recipients(1)
Recipients(1) = Me.cboPSMKempten.Value
'Sachbaerbeiter als Recipients(2)
Recipients(2) = Me.cboSachbearbeiter.Value
i = 3 'für Recipients(3)
Namen = Me.txtPSM.Value & ","
Do
NamenNeu = LTrim(Right(Namen, (Len(Namen) - InStr(1, Namen, ","))))
Recipients(i) = Left(Namen, InStr(1, Namen, ",") - 1)
i = i + 1
Namen = NamenNeu
Loop Until InStr(1, Namen, ",") = 0
Recipients(i) = Namen 'letzten Namen übernehmen
ReDim Preserve Recipients(i) 'Empfängerfeld redimensionieren
'Mail erstellen
Set session = CreateObject("Notes.NotesSession")
Set db = session.CURRENTDATABASE
On Error Goto Fehler
Set doc = db.CREATEDOCUMENT
doc.Form = "Memo"
doc.Subject = cstrBetreff
doc.body = "Text"
doc.CopyTo = Recipients() 'Komplettes Empfängerfeld
doc.SAVEMESSAGEONSEND = True
'Daten zum Auslesen
Set AttachME = doc.CREATERICHTEXTITEM("Attachment")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", strPath & "\CI Temp.xls") ', "Attachment")
'Zweites Attachment - Complaint Inquiry
Set AttachME = doc.CREATERICHTEXTITEM("Attachment")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", strPath & "\CI.xls") ', "Attachment")
doc.PostedDate = Now()
Call doc.send(True, strTo)
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Kill (strPath & "\CI Temp.xls") 'Datei löschen
Kill (strPath & "\CI.xls") 'Datei löschen
'Info an User
Warning = MsgBox("Complaint Inquiry was sent.", vbInformation, "INFORMATION")
Me.CmdSend.Enabled = False 'Send-Button deaktivieren
Me.lblSend.Enabled = False
Exit Sub
Fehler:
Kill (strPath & "\CI Temp.xls") 'Datei löschen
Kill (strPath & "\CI.xls") 'Datei löschen
Warning = MsgBox("Please change to Lotus Notes and close all databases except your inbox!!" _
& vbCrLf & vbCrLf & "Confirm this message and click the 'Send Inquiry'-Button again.", _
vbCritical, "ERROR")
End Sub