|
Ich habe vor langer Zeit ein VBA-Programm geschrieben, in dem einer Datenbank Daten "komfortabel" entlockt werden.
Dieses Programm läuft nicht mehr vollständig.
Die Probleme traten mit O365 erstmals auf.
Haben sie die Möglichkeit den Quelltext nach "groben Schnitzern" zu prüfen. Ich habe schon fast alles probiert, um die Ursache zu finden.
Die Datenbank habe ich seit 2014 nicht mehr verändert.
Laufzeitfehler 9 ist das Stichwort
Option Compare Database
Public betreff, BauL_mail, BerL_mail, datei, datei1, text As String
Private Sub Form_Current()
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
Dim BauL_sql, BerL_sql, GL_sql, OP_sql, mm_sql As Recordset
Dim sql, BauL_kurz, m_filter As String
Dim i, j, k, l, m, betrag As Double
Dim zeile As Integer
Dim ok As Boolean
Dim betrieb, shkz, typ, sto, bez, kre, anw, ewb, stritt, si, rat, ver, dif, unt, ssr, merk, datumsformat As String
Dim jetzt As Date
shkz = "H"
betrieb = "090040"
typ = "3"
sto = "STO"
bez = "BEZ"
kre = "KRE"
anw = "ANW"
ewb = "EWB"
stritt = "STR"
si = "SI"
rat = "RAT"
ver = "VER"
dif = "DIF"
unt = "UNT"
ssr = "SSR"
Set db = CurrentDb
DoCmd.Hourglass True
sql = "delete * from opdeb"
db.Execute (sql)
'sql = "INSERT INTO opdeb ( Kundennr, shkz, Betrag, Merkmal, Bezeichnung, Kst, betrag_abs, rnr, rdatum, datum, Betrieb, beleg, faell, BL,Kst_Bez,Belegnr,BuText ) " _
& "SELECT DISTINCT BRZGRUPPE_OPDEBTEIL.PersKto, BRZGRUPPE_OPDEBTEIL.SHKz, [BRZGRUPPE_OPDEBTEIL]![FWBetrag] AS betrag, " _
& "Mid([Merkmal],1,3) AS Ausdr2, BRZGRUPPE_DEBITOR.KurzBezeichnung, BRZGRUPPE_OPDEBTEIL.KstNr, IIf([BRZGRUPPE_OPDEBTEIL]![SHKz]='" & shkz & "', " _
& "[BRZGRUPPE_OPDEBTEIL]![FWBetrag]*-1,[BRZGRUPPE_OPDEBTEIL]![FWBetrag]) AS betrag_abs, [BRZGRUPPE_OPDEB]![RechnungNr] AS Ausdr3," _
& "BRZGRUPPE_OPDEB.BelegDatum, Now() AS Ausdr1, BRZGRUPPE_OPDEBTEIL.BetrNr, BRZGRUPPE_OPDEBTEIL.BelegID, BRZGRUPPE_OPDEBTEIL.NettoFaell," _
& "BRZGRUPPE_KOSTENST.KstLeiterKuerzel, BRZGRUPPE_KOSTENST.KurzName, BRZGRUPPE_FIBUCODE.BelegNr, BRZGRUPPE_OPDEBTEIL.BuText " _
& "FROM (((BRZGRUPPE_OPDEBTEIL LEFT JOIN BRZGRUPPE_DEBITOR ON (BRZGRUPPE_OPDEBTEIL.PersKto = BRZGRUPPE_DEBITOR.PersKto) " _
& "AND (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_DEBITOR.BetrNr)) LEFT JOIN BRZGRUPPE_OPDEB ON (BRZGRUPPE_OPDEBTEIL.BelegID = BRZGRUPPE_OPDEB.BelegID) " _
& "AND (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_OPDEB.BetrNr)) LEFT JOIN BRZGRUPPE_FIBUCODE ON (BRZGRUPPE_OPDEBTEIL.BelegID = BRZGRUPPE_FIBUCODE.BelegID) " _
& "AND (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_FIBUCODE.BetrNr)) LEFT JOIN BRZGRUPPE_KOSTENST ON (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_KOSTENST.VerbBetrNr) " _
& "AND (BRZGRUPPE_OPDEBTEIL.KstNr = BRZGRUPPE_KOSTENST.KstNr) " _
& "WHERE (((BRZGRUPPE_OPDEB.BelegDatum) > #12/31/2000#) And ((BRZGRUPPE_OPDEBTEIL.BetrNr) = '" & betrieb & "') " _
& "And ((BRZGRUPPE_OPDEBTEIL.AusgleichsId) Is Null) And (BRZGRUPPE_KOSTENST.KstTyp) = '" & typ & "')) " _
& "ORDER BY BRZGRUPPE_OPDEBTEIL.PersKto;"
sql = "INSERT INTO opdeb ( Kundennr, shkz, Betrag, Merkmal, Bezeichnung, Kst, betrag_abs, rnr, rdatum, datum, Betrieb, beleg, faell, BL,Kst_Bez,Belegnr,BuText,Typ ) " _
& "SELECT DISTINCT BRZGRUPPE_OPDEBTEIL.PersKto, BRZGRUPPE_OPDEBTEIL.SHKz, [BRZGRUPPE_OPDEBTEIL]![FWBetrag] AS betrag, " _
& "Mid([Merkmal],1,3) AS Ausdr2, BRZGRUPPE_DEBITOR.KurzBezeichnung, BRZGRUPPE_OPDEBTEIL.KstNr, IIf([BRZGRUPPE_OPDEBTEIL]![SHKz]='" & shkz & "', " _
& "[BRZGRUPPE_OPDEBTEIL]![FWBetrag]*-1,[BRZGRUPPE_OPDEBTEIL]![FWBetrag]) AS betrag_abs, [BRZGRUPPE_OPDEB]![RechnungNr] AS Ausdr3," _
& "BRZGRUPPE_OPDEB.BelegDatum, Now() AS Ausdr1, BRZGRUPPE_OPDEBTEIL.BetrNr, BRZGRUPPE_OPDEBTEIL.BelegID, BRZGRUPPE_OPDEBTEIL.NettoFaell," _
& "BRZGRUPPE_KOSTENST.KstLeiterKuerzel, BRZGRUPPE_KOSTENST.KurzName, BRZGRUPPE_FIBUCODE.BelegNr, BRZGRUPPE_OPDEBTEIL.BuText, BRZGRUPPE_KOSTENST.KstTyp " _
& "FROM (((BRZGRUPPE_OPDEBTEIL LEFT JOIN BRZGRUPPE_DEBITOR ON (BRZGRUPPE_OPDEBTEIL.PersKto = BRZGRUPPE_DEBITOR.PersKto) " _
& "AND (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_DEBITOR.BetrNr)) LEFT JOIN BRZGRUPPE_OPDEB ON (BRZGRUPPE_OPDEBTEIL.BelegID = BRZGRUPPE_OPDEB.BelegID) " _
& "AND (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_OPDEB.BetrNr)) LEFT JOIN BRZGRUPPE_FIBUCODE ON (BRZGRUPPE_OPDEBTEIL.BelegID = BRZGRUPPE_FIBUCODE.BelegID) " _
& "AND (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_FIBUCODE.BetrNr)) LEFT JOIN BRZGRUPPE_KOSTENST ON (BRZGRUPPE_OPDEBTEIL.BetrNr = BRZGRUPPE_KOSTENST.VerbBetrNr) " _
& "AND (BRZGRUPPE_OPDEBTEIL.KstNr = BRZGRUPPE_KOSTENST.KstNr) " _
& "WHERE (((BRZGRUPPE_OPDEB.BelegDatum) > #12/31/2000#) And ((BRZGRUPPE_OPDEBTEIL.BetrNr) = '" & betrieb & "') " _
& "And ((BRZGRUPPE_OPDEBTEIL.AusgleichsId) Is Null)) " _
& "ORDER BY BRZGRUPPE_OPDEBTEIL.PersKto;"
'And ((BRZGRUPPE_KOSTENST.KstTyp) = '" & typ & "')) "
db.Execute (sql)
sql = "DELETE opdeb.Betrag From opdeb WHERE (((opdeb.Betrag)=0.01))"
db.Execute (sql)
sql = "DELETE opdeb.Typ From opdeb WHERE (((opdeb.Typ)<> '" & typ & "'))"
db.Execute (sql)
sql = " DELETE Merkmal From opdeb WHERE Merkmal='" & sto & "' or Merkmal='" & bez & "' or Merkmal='" & kre & "' or Merkmal='" & anw & "' or Merkmal='" & ewb & "' " _
& "or Merkmal='" & stritt & "' or Merkmal='" & si & "' or Merkmal='" & rat & "' or Merkmal='" & ver & "' or Merkmal='" & dif & "' or Merkmal='" & unt & "' " _
& "or Merkmal='" & ssr & "'"
'db.Execute (sql)
sql = "update opdeb set betrag_abs=betrag*-1 where shkz='" & shkz & "'"
db.Execute (sql)
shkz = "S"
sql = "update opdeb set betrag_abs=betrag where shkz='" & shkz & "'"
db.Execute (sql)
merk = "KK"
text = "Konkurs"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "LM"
text = "mögl. Rechtsstreit"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "MÄ"
text = "Mängel"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "AUS"
text = "Ausland"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "VU"
text = "Ford. verb. Unternehmen"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "SCH"
text = "Schriftverkehr"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "VK"
text = "Verwahrkonto"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "RL"
text = "Restleistungen"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "ARG"
text = "ARGE"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
text = "unbelastete Forderungen"
merk = "BÜ"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "PFL"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "GUT"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
merk = "RR"
sql = "update opdeb set mm_Text='" & text & "' where merkmal='" & merk & "'"
'db.Execute (sql)
sql = "UPDATE (opdeb INNER JOIN Bauleiter ON opdeb.BL = Bauleiter.BauLtr_Kuerzel) INNER JOIN Bereichsleiter ON Bauleiter.BauLtr_Bereich = Bereichsleiter.Berltr_bereich SET opdeb.gb = [Bauleiter]![BauLtr_Bereich], opdeb.BerLtr = [Bereichsleiter]![BerLtr_Kuerzel]"
db.Execute (sql)
datumsformat = "00"
trenn = "/"
sql = "UPDATE opdeb SET opdeb.KW = Trim(Str(Year(opdeb.faell))) & '" & trenn & "' & Format(Trim(Str(dt_Kalenderwoche(opdeb.faell))),'" & datumsformat & "')"
db.Execute (sql)
DoCmd.Hourglass False
' ##########################################################################
' ** Bauleiter abarbeiten
' ##########################################################################
text = "Im Anhang finden Sie die OP-Liste Stand " & Format(Now, "hh") & ":" & Format(Now, "nn") & "Uhr ." & vbCr & _
"Bitte denken Sie auch an Rechnungsrückläufe für die offenen Posten." & vbCr & _
"Bei überfälligen Rechnungen bitte bei AG anrufen und Info an B. Kehrle." & vbCr & _
"Sollten Sie die Liste in Excel benötigen, dann sprechen Sie mich an." & vbCr & vbCr & _
"Mit freundlichen Grüßen" & vbCr & _
"Jan Sönnichsen" & vbCr & vbCr & _
"Diese Mail wurde automatisch erstellt"
sql = "Select * from Bauleiter"
Set BauL_sql = DBEngine(0)(0).OpenRecordset(sql)
If BauL_sql.RecordCount > 0 Then
BauL_sql.MoveLast
BauL_sql.MoveFirst
j = 1
For i = 1 To BauL_sql.RecordCount
BauL_kurz = BauL_sql!BauLtr_Kuerzel
BauL_mail = BauL_sql!BauLtr_email
Me.BL.Value = BauL_kurz
datei = "T:\OP\OP_" & BauL_kurz & ".pdf"
'**************************************************************************************
' Testzwecke
BauL_mail = "jan.soennichsen@vstr.de"
DoCmd.OutputTo acOutputReport, "Bauleiter_rpt", acFormatPDF, datei
If BauL_mail <> "" Then
ok = email_senden(BauL_mail)
End If
'**************************************************************************************
Kill datei
BauL_sql.MoveNext
Next
End If
' ##########################################################################
' ** Bereichsleiter abarbeiten
' ##########################################################################
text = "Im Anhang finden Sie die OP-Liste Stand " & Format(Now, "hh") & ":" & Format(Now, "nn") & "Uhr ." & vbCr & vbCr & vbCr & _
"Mit freundlichen Grüßen" & vbCr & _
"Jan Sönnichsen" & vbCr & vbCr & _
"Diese Mail wurde automatisch erstellt"
datei = ""
sql = "Select * from Bereichsleiter"
Set BerL_sql = DBEngine(0)(0).OpenRecordset(sql)
If BerL_sql.RecordCount > 0 Then
Debug.Print BerL_sql.RecordCount
BerL_sql.MoveLast
BerL_sql.MoveFirst
j = 1
For i = 1 To BerL_sql.RecordCount
BauL_kurz = BerL_sql!BerLtr_Kuerzel
BauL_mail = BerL_sql!BerLtr_email
Me.BL.Value = BerL_sql!BerLtr_bereich
BauL_Bereich = BerL_sql!BerLtr_bereich
m = 1
datei1 = "T:\OP\OP_Bereich_" & BauL_Bereich & "_" & Str(dt_Kalenderwoche(Now())) & "_KW.xls"
jetzt = DateValue(Format(Now(), "yyyy-mm-dd"))
DoCmd.Hourglass True
Set xlApp = New Excel.Application
With xlApp
.Visible = True
.Workbooks.Add
.Workbooks(1).Worksheets.Add
.Workbooks(1).Worksheets.Add
For m = 1 To 4
zeile = 0
m_filter = Trim(Str(m))
Select Case m
Case 1
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE (Merkmale.M_Liste='" & m_filter & "' or Merkmale.M_Liste Is Null) and opdeb.gb='" & BauL_Bereich & "' order by faell, rnr"
Case 2
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE Merkmale.M_Liste='" & m_filter & "' and opdeb.gb='" & BauL_Bereich & "' order by konto, rnr,faell"
Case 3
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE Merkmale.M_Liste='" & m_filter & "' and opdeb.gb='" & BauL_Bereich & "'order by konto, rnr,faell"
Case 4
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE faell<=now() and opdeb.gb='" & BauL_Bereich & "' order by konto, kst, faell"
End Select
Set OP_sql = DBEngine(0)(0).OpenRecordset(sql)
If OP_sql.RecordCount <> 0 Then
' .Visible = False
OP_sql.MoveLast
OP_sql.MoveFirst
Set xlSh = .Workbooks(1).Worksheets(m)
With xlSh
.Activate
Select Case m
Case 1
.Name = "OP" & Str(dt_Kalenderwoche(Now())) & "_" & Str(Year(Now()))
Case 2
.Name = "ausgeblendete Merkmale" & Str(dt_Kalenderwoche(Now())) & "_" & Str(Year(Now()))
Case 3
.Name = "geringwertige Merkmale" & Str(dt_Kalenderwoche(Now())) & "_" & Str(Year(Now()))
Case 4
.Name = "säumige Zahler"
End Select
.Cells(1, 1).Value = "überfällige Forderungen"
.Cells(2, 1).Value = "fällige Forderungen"
.Cells(3, 1).Value = "weitere offene Forderungen"
.Cells(4, 1).Value = "Forderungen gesamt"
.Cells(5, 1).Value = "Teilsumme nach Filter"
.Cells(5, 5).FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[999]C)"
With .Range(xlSh.Cells(1, 7), xlSh.Cells(5, 14))
.MergeCells = True
.HorizontalAlignment = xlRight
End With
For p = 1 To 5
With .Range(xlSh.Cells(p, 1), xlSh.Cells(p, 2))
.MergeCells = True
.HorizontalAlignment = xlRight
End With
Next p
.Cells(1, 3).Value = "am"
.Cells(2, 3).Value = "bis einschl."
.Cells(3, 3).Value = "ab"
.Range(xlSh.Cells(1, 3), xlSh.Cells(3, 3)).HorizontalAlignment = xlRight
.Cells(1, 4).Value = DateValue(Format(Now(), "dd.mm.yyyy"))
.Cells(2, 4).FormulaR1C1 = "=R[-1]+6"
.Cells(3, 4).FormulaR1C1 = "=R[-2]+7"
.Range(xlSh.Cells(1, 4), xlSh.Cells(3, 4)).NumberFormat = "m/d/yyyy"
.Cells(1, 5).FormulaR1C1 = "=SUMIF(R[6]C[3]:R[999]C[3],""<=""&RC[-1],R[6]C:R[999]C)"
.Cells(2, 5).FormulaR1C1 = "=SUMIF(R[5]C[3]:R[999]C[3],""<=""&RC[-1],R[5]C:R[999]C)-R[-1]C"
.Cells(3, 5).FormulaR1C1 = "=SUMIF(R[4]C[3]:R[999]C[3],"">=""&RC[-1],R[4]C:R[999]C)"
.Cells(4, 5).FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
'## neuer Code 2014/10/2
.Cells(1, 6).FormulaR1C1 = "=COUNTIF(R[6]C[2]:R[999]C[2],""<=""&RC[-2])"
.Cells(2, 6).FormulaR1C1 = "=COUNTIF(R[5]C[2]:R[998]C[2],""<=""&RC[-2])-R[-1]C"
.Cells(3, 6).FormulaR1C1 = "=COUNTIF(R[4]C[2]:R[997]C[2],"">""&R[-1]C[-2])"
.Cells(4, 6).FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
.Range(xlSh.Cells(1, 6), xlSh.Cells(4, 6)).NumberFormat = "General"
'##
'## Änderung 2014/10/02 (format bis Spalte 6)
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Name = "Arial"
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Bold = True
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Size = 11
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Color = -16777024
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.TintAndShade = 0
'##
.Range(xlSh.Cells(1, 5), xlSh.Cells(5, 5)).NumberFormat = "#,##0.00"
.Cells(6, 1).Value = "Beleg-NR"
.Cells(6, 2).Value = "Beleg-DAT"
.Cells(6, 3).Value = "RE-NR"
.Cells(6, 4).Value = "Konto"
.Cells(6, 5).Value = "Betrag"
.Cells(6, 6).Value = "KST"
.Cells(6, 7).Value = "BL"
.Cells(6, 8).Value = "Fällig"
.Cells(6, 9).Value = "MM"
.Cells(6, 10).Value = "Kunde"
.Cells(6, 11).Value = "KST-Bez"
.Cells(6, 12).Value = "KW"
.Cells(6, 13).Value = "BerL"
.Cells(6, 14).Value = "Bu-Text"
.Cells.Rows(6).AutoFilter
.Cells.Rows(6).Font.Bold = True
With xlSh.PageSetup
'## Änderung 2014/10/04 (Pfad für Logo)
.RightHeaderPicture.FileName = "\\progsrv01\daten\Scanner\LOGO_BL_KLEIN.JPG"
'##
.LeftHeader = "&""Arial,Standard""&12&A"
.RightHeader = "&""Arial,Standard""&14VSTR AG Rodewisch"
.LeftFooter = "&""Arial,Standard""&8Stand: " & Now()
.CenterFooter = "&""Arial,Standard""&12Vertraulich"
.RightFooter = "&""Arial,Standard""&12Seite &P von &N"
.PrintTitleRows = "$1:$6"
.PrintGridlines = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 4
.Orientation = xlLandscape
End With
For k = 1 To OP_sql.RecordCount
.Cells(k + 6, 1).Value = OP_sql!belegnr
.Cells(k + 6, 2).Value = OP_sql!rdatum
.Cells(k + 6, 3).Value = OP_sql!rnr
.Cells(k + 6, 4).Value = OP_sql!kundennr
.Cells(k + 6, 5).Value = OP_sql!betrag_abs
.Cells(k + 6, 6).Value = OP_sql!kst
.Cells(k + 6, 7).Value = OP_sql!BL
.Cells(k + 6, 8).Value = OP_sql!faell
.Cells(k + 6, 9).Value = OP_sql!merkmal
.Cells(k + 6, 10).Value = OP_sql!bezeichnung
.Cells(k + 6, 11).Value = OP_sql!kst_bez
.Cells(k + 6, 12).Value = OP_sql!kw
.Cells(k + 6, 13).Value = OP_sql!BerLtr
.Cells(k + 6, 14).Value = OP_sql!BuText
OP_sql.MoveNext
Next
.Visible = True
.Columns("H:H").NumberFormat = "m/d/yyyy"
.Columns("E:E").NumberFormat = "#,##0.00"
.UsedRange.Columns.AutoFit
With .Range(xlSh.Cells(6, 1), xlSh.Cells(6, 14)).Interior
.Pattern = 1 'xlSolid
.PatternColorIndex = -4105 'xlAutomatic
.ThemeColor = 1 'xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
'#######################################################
Debug.Print .UsedRange.SpecialCells(xlCellTypeLastCell).Row
zeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
'#######################################################
.Range(xlSh.Cells(6, 4), xlSh.Cells(zeile, 4)).HorizontalAlignment = xlCenter
.Range(xlSh.Cells(6, 7), xlSh.Cells(zeile, 9)).HorizontalAlignment = xlCenter
.Range(xlSh.Cells(6, 10), xlSh.Cells(zeile, 10)).ColumnWidth = 15
.Range(xlSh.Cells(6, 5), xlSh.Cells(zeile, 5)).ColumnWidth = 13.5
.Range(xlSh.Cells(6, 3), xlSh.Cells(zeile, 3)).ColumnWidth = 14
'###########################################################################################################
' Bedingte Formatierungen
'###########################################################################################################
'## Änderung 2014/10/02 (Operator von xlLess zu xlLessEqual)
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, Formula1:="=$D$1"
'##
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions.Count).SetFirstPriority
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(1).Font.Color = 255
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(1).Font.TintAndShade = 0
' .Range(Cells(7, 8), Cells(zeile, 8)).FormatConditions(1).Font.FormatConditions(1).StopIfTrue = False
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(1).StopIfTrue = False
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=10000"
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Count).SetFirstPriority
With .Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).StopIfTrue = False
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=100000"
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Count).SetFirstPriority
With .Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 39423
.TintAndShade = 0
End With
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).StopIfTrue = False
.Cells(7, 4).Select
'###########################################################################################################
For l = 7 To 12
With .UsedRange.Borders(l)
.LineStyle = 1
.ColorIndex = 0
.TintAndShade = 0
.Weight = 2
End With
Next l
End With
.ActiveWindow.FreezePanes = True
.ActiveWindow.DisplayGridlines = False
End If
Next
'#################
'Merkmalliste ausfüllen
'#################
Set xlSh = .Workbooks(1).Worksheets(5)
With xlSh
.Activate
.Name = "Merkmale"
.Cells(1, 1) = "Merkmal"
.Cells(1, 2) = "Bezeichnung"
.Cells(1, 3) = "Liste"
.Cells(1, 4) = "Beschreibung"
.Cells(1, 5) = "Randbedingungen"
'#################
sql = "select * from merkmale order by M_Liste,M_Merkmal"
Set mm_sql = DBEngine(0)(0).OpenRecordset(sql)
If mm_sql.RecordCount > 0 Then
mm_sql.MoveLast
mm_sql.MoveFirst
For q = 1 To mm_sql.RecordCount
.Cells(q + 1, 1) = mm_sql!M_Merkmal
.Cells(q + 1, 2) = mm_sql!M_Bezeichnung
.Cells(q + 1, 3) = mm_sql!M_Liste
.Cells(q + 1, 4) = mm_sql!M_Beschreibung
.Cells(q + 1, 5) = mm_sql!M_Randbedingungen
liste = mm_sql!M_Liste
mm_sql.MoveNext
If Not mm_sql.EOF Then
If mm_sql!M_Liste <> liste Then
With .Range(xlSh.Cells(q + 1, 1), xlSh.Cells(q + 1, 5)).Borders(9)
.LineStyle = 1
.ColorIndex = 0
.TintAndShade = 0
.Weight = 2
End With
End If
End If
Next q
.UsedRange.Columns.AutoFit
zeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Range(xlSh.Cells(1, 4), xlSh.Cells(zeile, 5)).ColumnWidth = 40
.Range(xlSh.Cells(1, 4), xlSh.Cells(zeile, 5)).WrapText = True
.UsedRange.VerticalAlignment = xlTop
End If
End With
.ActiveWindow.DisplayGridlines = False
.ActiveSheet.ListObjects.Add(xlSrcRange, .Range(xlSh.Cells(1, 1), xlSh.Cells(zeile, 5)), , xlYes).Name = "Merkmale"
.ActiveSheet.ListObjects("Merkmale").TableStyle = "TableStyleLight1"
'#################
'Seiten formatieren
'#################
With xlSh.PageSetup
.LeftHeader = "&""Arial,Standard""&12&A"
.CenterHeader = ""
.RightHeader = "&""Arial,Standard""&14VSTR AG Rodewisch"
.LeftFooter = "&""Arial,Standard""&8Stand: " & Now()
.CenterFooter = ""
.RightFooter = "&""Arial,Standard""&12Seite &P von &N"
.PrintTitleRows = "$1:$1"
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Set xlSh = .Workbooks(1).Worksheets(1)
With xlSh
.Activate
.Cells(1, 1).Select
End With
'#################
.DisplayAlerts = False
.ActiveWorkbook.SaveAs FileName:=datei1, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False, ConflictResolution:=xlLocalSessionChanges
.ActiveWorkbook.Close savechanges:=False
.Quit
End With
DoCmd.Hourglass False
Set xlSh = Nothing
Set xlApp = Nothing
'**************************************************************************************
' DoCmd.OutputTo acOutputReport, "GL_rpt", acFormatPDF, datei
ok = email_senden(BauL_mail)
'**************************************************************************************
' End If
BerL_sql.MoveNext
' Debug.Print BauL_mail
Next
End If
' ##########################################################################
' ** GL abarbeiten
' ##########################################################################
text = "Im Anhang finden Sie die OP-Liste Stand " & Format(Now, "hh") & ":" & Format(Now, "nn") & "Uhr ." & vbCr & vbCr & vbCr & _
"Mit freundlichen Grüßen" & vbCr & _
"Jan Sönnichsen" & vbCr & vbCr & _
"Diese Mail wurde automatisch erstellt"
BauL_mail = ""
m = 1
datei1 = "T:\OP\OP_VSTR_" & Str(dt_Kalenderwoche(Now())) & "_KW.xls"
jetzt = DateValue(Format(Now(), "yyyy-mm-dd"))
DoCmd.Hourglass True
sql = "Select * from Geschaeftsleitung"
Set GL_sql = DBEngine(0)(0).OpenRecordset(sql)
GL_sql.MoveLast
If GL_sql.RecordCount > 0 Then
GL_sql.MoveFirst
j = 1
For i = 1 To GL_sql.RecordCount
BauL_mail = GL_sql!GL_Email & ";" & BauL_mail
GL_sql.MoveNext
Next
datei = ""
Set xlApp = New Excel.Application
With xlApp
.Visible = True
.Workbooks.Add
.Workbooks(1).Worksheets.Add
.Workbooks(1).Worksheets.Add
For m = 1 To 4
m_filter = Trim(Str(m))
Select Case m
Case 1
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE Merkmale.M_Liste='" & m_filter & "' or Merkmale.M_Liste Is Null order by faell, rnr"
Case 2
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE Merkmale.M_Liste='" & m_filter & "' order by konto, rnr,faell"
Case 3
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE Merkmale.M_Liste='" & m_filter & "' order by konto, rnr,faell"
Case 4
sql = "SELECT opdeb.*, Merkmale.M_Liste FROM opdeb LEFT JOIN Merkmale ON opdeb.Merkmal = Merkmale.M_Merkmal WHERE faell<=now() order by konto, kst, faell"
End Select
Set OP_sql = DBEngine(0)(0).OpenRecordset(sql)
If OP_sql.RecordCount <> 0 Then
' .Visible = False
OP_sql.MoveLast
OP_sql.MoveFirst
Set xlSh = .Workbooks(1).Worksheets(m)
With xlSh
.Activate
Select Case m
Case 1
.Name = "OP" & Str(dt_Kalenderwoche(Now())) & "_" & Str(Year(Now()))
Case 2
.Name = "ausgeblendete Merkmale" & Str(dt_Kalenderwoche(Now())) & "_" & Str(Year(Now()))
Case 3
.Name = "geringwertige Merkmale" & Str(dt_Kalenderwoche(Now())) & "_" & Str(Year(Now()))
Case 4
.Name = "säumige Zahler"
End Select
.Cells(1, 1).Value = "überfällige Forderungen"
.Cells(2, 1).Value = "fällige Forderungen"
.Cells(3, 1).Value = "weitere offene Forderungen"
.Cells(4, 1).Value = "Forderungen gesamt"
.Cells(5, 1).Value = "Teilsumme nach Filter"
.Cells(5, 5).FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[999]C)"
'## Änderung 2014/10/02 (bis Spalte 7)
' G1-N5 verbinden und zentrieren
With .Range(xlSh.Cells(1, 7), xlSh.Cells(5, 14))
.MergeCells = True
.HorizontalAlignment = xlRight
End With
'##
For i = 1 To 5
With .Range(xlSh.Cells(i, 1), xlSh.Cells(i, 2))
.MergeCells = True
.HorizontalAlignment = xlRight
End With
Next i
.Cells(1, 3).Value = "am"
.Cells(2, 3).Value = "bis einschl."
.Cells(3, 3).Value = "ab"
.Range(xlSh.Cells(1, 3), xlSh.Cells(3, 3)).HorizontalAlignment = xlRight
.Cells(1, 4).Value = DateValue(Format(Now(), "dd.mm.yyyy"))
.Cells(2, 4).FormulaR1C1 = "=R[-1]+6"
.Cells(3, 4).FormulaR1C1 = "=R[-2]+7"
.Range(xlSh.Cells(1, 4), xlSh.Cells(3, 4)).NumberFormat = "m/d/yyyy"
.Cells(1, 5).FormulaR1C1 = "=SUMIF(R[6]C[3]:R[999]C[3],""<=""&RC[-1],R[6]C:R[999]C)"
.Cells(2, 5).FormulaR1C1 = "=SUMIF(R[5]C[3]:R[999]C[3],""<=""&RC[-1],R[5]C:R[999]C)-R[-1]C"
.Cells(3, 5).FormulaR1C1 = "=SUMIF(R[4]C[3]:R[999]C[3],"">=""&RC[-1],R[4]C:R[999]C)"
.Cells(4, 5).FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
'## neuer Code 2014/10/2
.Cells(1, 6).FormulaR1C1 = "=COUNTIF(R[6]C[2]:R[999]C[2],""<=""&RC[-2])"
.Cells(2, 6).FormulaR1C1 = "=COUNTIF(R[5]C[2]:R[998]C[2],""<=""&RC[-2])-R[-1]C"
.Cells(3, 6).FormulaR1C1 = "=COUNTIF(R[4]C[2]:R[997]C[2],"">""&R[-1]C[-2])"
.Cells(4, 6).FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)"
.Range(xlSh.Cells(1, 6), xlSh.Cells(4, 6)).NumberFormat = "General"
'##
'## Änderung 2014/10/02 (Erweiterung bis Spalte 6)
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Name = "Arial"
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Bold = True
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Size = 11
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.Color = -16777024
.Range(xlSh.Cells(1, 1), xlSh.Cells(1, 6)).Font.TintAndShade = 0
'##
.Range(xlSh.Cells(1, 5), xlSh.Cells(5, 5)).NumberFormat = "#,##0.00"
.Cells(6, 1).Value = "Beleg-NR"
.Cells(6, 2).Value = "Beleg-DAT"
.Cells(6, 3).Value = "RE-NR"
.Cells(6, 4).Value = "Konto"
.Cells(6, 5).Value = "Betrag"
.Cells(6, 6).Value = "KST"
.Cells(6, 7).Value = "BL"
.Cells(6, 8).Value = "Fällig"
.Cells(6, 9).Value = "MM"
.Cells(6, 10).Value = "Kunde"
.Cells(6, 11).Value = "KST-Bez"
.Cells(6, 12).Value = "KW"
.Cells(6, 13).Value = "BerL"
.Cells(6, 14).Value = "Bu-Text"
.Cells.Rows(6).AutoFilter
.Cells.Rows(6).Font.Bold = True
With xlSh.PageSetup
'## Änderung 2014/10/04 (Pfad für Logo)
.RightHeaderPicture.FileName = "\\progsrv01\daten\Scanner\LOGO_BL_KLEIN.JPG"
'##
.LeftHeader = "&""Arial,Standard""&12&A"
.RightHeader = "&""Arial,Standard""&14VSTR AG Rodewisch"
.LeftFooter = "&""Arial,Standard""&8Stand: " & Now()
.CenterFooter = "&""Arial,Standard""&12Vertraulich"
.RightFooter = "&""Arial,Standard""&12Seite &P von &N"
.PrintTitleRows = "$1:$6"
.PrintGridlines = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 4
.Orientation = xlLandscape
End With
For k = 1 To OP_sql.RecordCount
.Cells(k + 6, 1).Value = OP_sql!belegnr
.Cells(k + 6, 2).Value = OP_sql!rdatum
.Cells(k + 6, 3).Value = OP_sql!rnr
.Cells(k + 6, 4).Value = OP_sql!kundennr
.Cells(k + 6, 5).Value = OP_sql!betrag_abs
.Cells(k + 6, 6).Value = OP_sql!kst
.Cells(k + 6, 7).Value = OP_sql!BL
.Cells(k + 6, 8).Value = OP_sql!faell
.Cells(k + 6, 9).Value = OP_sql!merkmal
.Cells(k + 6, 10).Value = OP_sql!bezeichnung
.Cells(k + 6, 11).Value = OP_sql!kst_bez
.Cells(k + 6, 12).Value = OP_sql!kw
.Cells(k + 6, 13).Value = OP_sql!BerLtr
.Cells(k + 6, 14).Value = OP_sql!BuText
OP_sql.MoveNext
Next
.Visible = True
.Columns("H:H").NumberFormat = "m/d/yyyy"
.Columns("E:E").NumberFormat = "#,##0.00"
.UsedRange.Columns.AutoFit
With .Range(xlSh.Cells(6, 1), xlSh.Cells(6, 14)).Interior
.Pattern = 1 'xlSolid
.PatternColorIndex = -4105 'xlAutomatic
.ThemeColor = 1 'xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
'#######################################################
zeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
'zeile = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
'#######################################################
.Range(xlSh.Cells(6, 4), xlSh.Cells(zeile, 4)).HorizontalAlignment = xlCenter
.Range(xlSh.Cells(6, 7), xlSh.Cells(zeile, 9)).HorizontalAlignment = xlCenter
.Range(xlSh.Cells(6, 10), xlSh.Cells(zeile, 10)).ColumnWidth = 15
.Range(xlSh.Cells(6, 5), xlSh.Cells(zeile, 5)).ColumnWidth = 13.5
.Range(xlSh.Cells(6, 3), xlSh.Cells(zeile, 3)).ColumnWidth = 14
'###########################################################################################################
' Bedingte Formatierungen
'###########################################################################################################
'## Änderung 2014/10/02 (Operator von xlLess zu xlLessEqual)
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, Formula1:="=$D$1"
'##
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions.Count).SetFirstPriority
With .Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(1).Font
.Color = 255
.TintAndShade = 0
End With
.Range(xlSh.Cells(7, 8), xlSh.Cells(zeile, 8)).FormatConditions(1).StopIfTrue = False
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=10000"
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Count).SetFirstPriority
With .Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).StopIfTrue = False
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=100000"
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions.Count).SetFirstPriority
With .Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 39423
.TintAndShade = 0
End With
.Range(xlSh.Cells(7, 5), xlSh.Cells(zeile, 5)).FormatConditions(1).StopIfTrue = False
.Cells(7, 4).Select
'###########################################################################################################
For l = 7 To 12
With .UsedRange.Borders(l)
.LineStyle = 1
.ColorIndex = 0
.TintAndShade = 0
.Weight = 2
End With
Next l
End With
.ActiveWindow.FreezePanes = True
.ActiveWindow.DisplayGridlines = False
End If
Next
'#################
'Merkmalliste ausfüllen
'#################
Set xlSh = .Workbooks(1).Worksheets(5)
With xlSh
.Activate
.Name = "Merkmale"
.Cells(1, 1) = "Merkmal"
.Cells(1, 2) = "Bezeichnung"
.Cells(1, 3) = "Liste"
.Cells(1, 4) = "Beschreibung"
.Cells(1, 5) = "Randbedingungen"
'#################
sql = "select * from merkmale order by M_Liste,M_Merkmal"
Set mm_sql = DBEngine(0)(0).OpenRecordset(sql)
If mm_sql.RecordCount > 0 Then
mm_sql.MoveLast
mm_sql.MoveFirst
For i = 1 To mm_sql.RecordCount
.Cells(i + 1, 1) = mm_sql!M_Merkmal
.Cells(i + 1, 2) = mm_sql!M_Bezeichnung
.Cells(i + 1, 3) = mm_sql!M_Liste
.Cells(i + 1, 4) = mm_sql!M_Beschreibung
.Cells(i + 1, 5) = mm_sql!M_Randbedingungen
liste = mm_sql!M_Liste
mm_sql.MoveNext
If Not mm_sql.EOF Then
If mm_sql!M_Liste <> liste Then
With .Range(xlSh.Cells(i + 1, 1), xlSh.Cells(i + 1, 5)).Borders(9)
.LineStyle = 1
.ColorIndex = 0
.TintAndShade = 0
.Weight = 2
End With
End If
End If
Next i
.UsedRange.Columns.AutoFit
zeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Range(xlSh.Cells(1, 4), xlSh.Cells(zeile, 5)).ColumnWidth = 40
.Range(xlSh.Cells(1, 4), xlSh.Cells(zeile, 5)).WrapText = True
.UsedRange.VerticalAlignment = xlTop
End If
End With
.ActiveWindow.DisplayGridlines = False
.ActiveSheet.ListObjects.Add(xlSrcRange, .Range(xlSh.Cells(1, 1), xlSh.Cells(zeile, 5)), , xlYes).Name = "Merkmale"
.ActiveSheet.ListObjects("Merkmale").TableStyle = "TableStyleLight1"
'#################
'Seiten formatieren
'#################
With xlSh.PageSetup
.LeftHeader = "&""Arial,Standard""&12&A"
.CenterHeader = ""
.RightHeader = "&""Arial,Standard""&14VSTR AG Rodewisch"
.LeftFooter = "&""Arial,Standard""&8Stand: " & Now()
.CenterFooter = ""
.RightFooter = "&""Arial,Standard""&12Seite &P von &N"
.PrintTitleRows = "$1:$1"
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Set xlSh = .Workbooks(1).Worksheets(1)
With xlSh
.Activate
.Cells(1, 1).Select
End With
'#################
.DisplayAlerts = False
.ActiveWorkbook.SaveAs FileName:=datei1, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False, ConflictResolution:=xlLocalSessionChanges
.ActiveWorkbook.Close savechanges:=False
.Quit
End With
Set xlSh = Nothing
Set xlApp = Nothing
DoCmd.Hourglass False
'**************************************************************************************
' DoCmd.OutputTo acOutputReport, "GL_rpt", acFormatPDF, datei
ok = email_senden(BauL_mail)
'**************************************************************************************
End If
End Sub
Public Function email_senden(BauL_mail) As Boolean
Dim olApp As Outlook.Application
Dim olNamespace As NameSpace
Dim objMailItem As MailItem
Dim objFolder As mapiFolder
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")
Set objFolder = olNamespace.GetDefaultFolder(olFolderInbox)
Set objMailItem = objFolder.Items.Add(olMailItem)
betreff = "OP-Liste Stand: " + Format(Now, "hh") + ":" + Format(Now, "nn")
'******************************************
'### zu Testzwecken
BauL_mail = "jan.soennichsen@vstr.de"
'******************************************
With objMailItem
.To = "" & ";" & BauL_mail
' .BCC = "jan.soennichsen@vstr.de"
.subject = betreff
.Body = text
If datei <> "" Then
.Attachments.Add datei
End If
If datei1 <> "" Then
.Attachments.Add datei1
End If
.Send
End With
olApp.ActiveWindow
SendKeys "%s"
SendKeys "%e"
email = True
Set objMailItem = Nothing
End Function
Private Sub Verlassen_Click()
DoCmd.Close
End Sub
|