Új hozzászólás Aktív témák

• #52513 TheSaint aktív tag Fferi50 #52503

  Új Válasz 2024-04-23 12:34:06 #52513

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  TheSaint

  aktív tag

  válasz Fferi50 #52503 üzenetére

  Ezek stimmelnek.
  Így néz ki a teljes kód, egy adatbázislekérés van a táblázatban. Még sose futottam bele ilyen megmagyarázhatatlan hibába:
  Private Sub Workbook_Open()
    ' Adatkapcsolatok frissítése
    ThisWorkbook.RefreshAll
    
    ' Azonnal elindítjuk az időzítőt, amely a háttérben fut
    StartTimer
End Sub
Sub StartTimer()
    ' Időzítő beállítása 15 másodpercre
    Application.OnTime Now + TimeValue("00:00:15"), "ThisWorkbook.ProcessAfterDelay"
End Sub
Sub ProcessAfterDelay()
    ' Ellenőrizze, hogy a munkafüzet meg van-e nyitva
    If ThisWorkbook.Name = "e.xlsm" Then
    
' Változók deklarálása
Dim ws1 As Worksheet ' "Munka1" lap
Dim ws3 As Worksheet ' "Munka3" lap
Dim filterRange As Range
Dim filterValues() As Variant
Dim filterValue As Variant
Dim bodyText As String
Dim emailTable As Object
Dim CDO_Mail As Object
Dim CDO_Config As Object
' CDO konfiguráció beállítása
Set CDO_Mail = CreateObject("CDO.Message")
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.."
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ""
CDO_Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ""
CDO_Config.Fields.Update
Set CDO_Mail.Configuration = CDO_Config
' Munkalapok beállítása
Set ws1 = ThisWorkbook.Sheets("Munka1")
Set ws3 = ThisWorkbook.Sheets("Munka3")
ws1.AutoFilterMode = False
' Szűrési tartomány beállítása a "Munka1" lapon (A-M oszlop)
Set filterRange = ws1.Range("A3:M" & ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row)
' Kiválasztott nevek definiálása
filterValues = Array("X", "Y")
' E-mail címek táblázatának inicializálása a "Munka3" lapon
Set emailTable = CreateEmailTable(ws3)
' Minden egyedi értékhez készítünk egy külön e-mailt
For Each filterValue In filterValues
' Szűrés a K oszlop alapján a "Munka1" lapon
filterRange.AutoFilter Field:=11, Criteria1:=filterValue
' Csak folytatjuk, ha vannak szűrt sorok
If Application.WorksheetFunction.Subtotal(103, filterRange.Columns(1)) > 1 Then
' E-mail tartalma összeállítása
bodyText = "" & filterValue & " m:" & vbCrLf & vbCrLf
bodyText = bodyText & "" & vbCrLf & vbCrLf
' HTML formátumban konvertált táblázat hozzáadása az üzenethez
bodyText = bodyText & RangetoHTML(filterRange.SpecialCells(xlCellTypeVisible))
' E-mail cím meghatározása a filterValue alapján a "Munka3" lapon
Dim emailCim As String
emailCim = GetEmailFromTable(emailTable, filterValue)
' Csak folytatjuk, ha sikerült e-mail címet meghatározni
If emailCim <> "" Then
' E-mail küldése CDO objektummal
With CDO_Mail
.Subject = "D"
.From = "@.hu"
.To = emailCim
.cc = "@.hu"
.HTMLBody = bodyText ' HTML formátumú tartalom hozzáadása az üzenethez
.Send
End With
End If
End If
' Szűrés törlése
ws1.AutoFilterMode = False
Next filterValue
' CDO objektumok bezárása
Set CDO_Mail = Nothing
Set CDO_Config = Nothing
        ' Időzítő újraindítása 1 percre
        Application.OnTime Now + TimeValue("00:01:00"), "ThisWorkbook.SaveAndCloseWorkbook"
    End If
End Sub
Sub SaveAndCloseWorkbook()
    ' Táblázat mentése és bezárása
    ThisWorkbook.Save
    ThisWorkbook.Close
End Sub
Function RangetoHTML(rng As Range)
    ' Függvény a táblázat HTML formátumban történő konvertálásához
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    ' Táblázat exportálása HTML fájlba
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    ' HTML fájlba mentés
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    ' HTML tartalom olvasása
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    
    ' Táblázat törlése és ideiglenes munkafüzet bezárása
    TempWB.Close SaveChanges:=False
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Function CreateEmailTable(ws As Worksheet) As Object
    ' E-mail címek táblázatának létrehozása és feltöltése
    Dim emailTable As Object
    Set emailTable = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    For i = 1 To lastRow
        Dim nev As String
        Dim email As String
        nev = ws.Cells(i, 2).Value
        email = ws.Cells(i, 3).Value
        emailTable(nev) = email
    Next i
    
    Set CreateEmailTable = emailTable
End Function
Function GetEmailFromTable(emailTable As Object, key As Variant) As String
    ' E-mail cím lekérdezése a táblázatból a megadott kulcs alapján
    On Error Resume Next
    GetEmailFromTable = emailTable(key)
    On Error GoTo 0
End Function
  

Új hozzászólás Aktív témák