Rozpis

Sub RozpisObrazek()

    ' Dim proměnné
    Dim cht As ChartObject
    Dim ws As Worksheet
    Dim rng As Range
    Dim DesktopPath As String
    Dim FileName As String
    Dim Mesic As String
    Dim DatumCas As String
    Dim UserResponse As VbMsgBoxResult

    ' Nastavení listu a rozsahu
    Set ws = ActiveSheet
    Set rng = ws.Range("D10:AJ24")

    ' Získání aktuálního měsíce z F10
    Mesic = ws.Range("F10").Value
    If Mesic = "" Then
        MsgBox "Buňka F10 je prázdná, nelze uložit.", vbExclamation
        Exit Sub
    End If

    ' Získání aktuálního data a času
    DatumCas = Format(Now, "yyyy-mm-dd hh-mm-ss")

    ' Cesta na plochu a vytvoření složky "Rozpisy", pokud neexistuje
    DesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Rozpisy\"
    If Dir(DesktopPath, vbDirectory) = "" Then
        MkDir DesktopPath
    End If

    ' Přidání názvu souboru do cesty
    FileName = DesktopPath & "Rozpis " & Mesic & " " & DatumCas & ".png"

    ' Kopírování rozsahu jako obrázku
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    ' Vytvoření dočasného objektu grafu
    Set cht = ws.ChartObjects.Add(Left:=rng.Left, Width:=rng.Width, Top:=rng.Top, Height:=rng.Height)
    With cht
        .Activate
        .Chart.Paste
        .Chart.Export FileName:=FileName, FilterName:="PNG"
        .Delete ' Smazání dočasného grafu
    End With

    ' Potvrzení uživateli
    UserResponse = MsgBox("Rozsah byl uložen jako obrázek na plochu: " & FileName & vbCrLf & _
                          "Chcete obrázek odeslat e-mailem?", vbYesNo + vbQuestion, "Odeslat e-mailem?")

    ' Pokud uživatel zvolí Ano, otevřeme Outlook a vytvoříme e-mail
    If UserResponse = vbYes Then
        OdeslatRozpisObrazek FileName, "Rozpis " & Mesic, ws.Name
    End If
End Sub

' Funkce pro odeslání e-mailu
Sub OdeslatRozpisObrazek(FilePath As String, FileName As String, ListName As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object

    ' Vytvoření instance aplikace Outlook
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .To = "" ' Zadejte e-mailovou adresu příjemce
        .SentOnBehalfOfName = "OstrahaBrno@ceskatelevize.cz" ' Odeslat jménem této adresy
        .Subject = "ČT Brno rozpis směn na měsíc " & ListName
        .Body = "V příloze najdeš svůj rozpis směn." & vbCrLf & _
                "Tak si jej hezky poznamenej a přijď včas!" & vbCrLf & vbCrLf & _
                "Vytvořeno: " & Now & vbCrLf & vbCrLf & _
                "Generováno a odesláno automatickým automatem."
        .Attachments.Add FilePath
        .Display ' Zobrazí e-mail před odesláním
    End With

    ' Vyčištění
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub