API tools faq
paste
Advertisement
Sanady

Mail and APP

Sanady
Jan 15th, 2019
1,335
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 11.87 KB | None | 0 0
raw download clone embed print report
  1. Dim poleInput As Variant
  2.  
  3. Sub TextBox1_Change()
  4.         poleInput = TextBox1.Text
  5. End Sub
  6.  
  7. Sub CommandButton1_Click()
  8.     If poleInput = "" Then
  9.         MsgBox "Input je prázdny, pridaj nejaké info!"
  10.     Else
  11.         'MsgBox (poleInput)
  12.        AddAppointments (poleInput)
  13.         AddAppointmentsAfterThreeMonths (poleInput)
  14.         MsgBox "Pripomienka úspešne poslatá!"
  15.     End If
  16. End Sub
  17.  
  18. Sub AddAppointments(pole As String)
  19. 'Update by Extendoffice 20180608
  20.    Dim i As Long
  21.     Dim xRg As Range
  22.     Dim xOutApp As Object
  23.     Dim xOutItem As Object
  24.    
  25.     Set xOutApp = CreateObject("Outlook.Application")
  26.     Set xRg = Range(pole)
  27.     For i = 1 To xRg.Rows.Count
  28.         Set xOutItem = xOutApp.CreateItem(1)
  29.         Debug.Print xRg.Cells(i, 1).Value
  30.         xOutItem.Subject = "Posla mail " & xRg.Cells(i, 2).Value
  31.         xOutItem.Location = "Office"
  32.         xOutItem.Start = xRg.Cells(i, 1).Value & " 11:00"
  33.         xOutItem.End = xRg.Cells(i, 1).Value & " 17:00"
  34.         xOutItem.BusyStatus = 2
  35.         xOutItem.ReminderSet = True
  36.         xOutItem.ReminderMinutesBeforeStart = "15"
  37.         xOutItem.Body = "Posla mail zamestnancovi " & xRg.Cells(i, 2).Value
  38.         xOutItem.Save
  39.         Set xOutItem = Nothing
  40.     Next
  41.     Set xOutApp = Nothing
  42. End Sub
  43.  
  44. Sub AddAppointmentsAfterThreeMonths(pole As String)
  45. 'Update by Extendoffice 20180608
  46.    Dim i As Long
  47.     Dim xRg As Range
  48.     Dim xOutApp As Object
  49.     Dim xOutItem As Object
  50.    
  51.     Set xOutApp = CreateObject("Outlook.Application")
  52.     Set xRg = Range(pole)
  53.    
  54.     For i = 1 To xRg.Rows.Count
  55.         Set xOutItem = xOutApp.CreateItem(1)
  56.         Debug.Print xRg.Cells(i, 1).Value
  57.         xOutItem.Subject = "Posla pripomienku " & xRg.Cells(i, 2).Value
  58.         xOutItem.Location = "Office"
  59.         xOutItem.Start = DateAdd("m", 3, xRg.Cells(i, 1)) & " 11:00"
  60.         xOutItem.End = DateAdd("m", 3, xRg.Cells(i, 1)) & " 17:00"
  61.         xOutItem.BusyStatus = 2
  62.         xOutItem.ReminderSet = True
  63.         xOutItem.ReminderMinutesBeforeStart = "15"
  64.         xOutItem.Body = "Posla pripomienku zamestnancovi " & xRg.Cells(i, 2).Value
  65.         xOutItem.Save
  66.         Set xOutItem = Nothing
  67.     Next
  68.     Set xOutApp = Nothing
  69. End Sub
  70.  
  71. Sub SendEMail(uvod As Integer)
  72. 'update by Extendoffice 20160506
  73.    Dim xEmail As String
  74.     Dim xSubj As String
  75.     Dim xMsg As String
  76.     Dim xURL As String
  77.     Dim i As Integer
  78.     Dim k As Double
  79.     Dim OutApp As Object
  80.     Dim OutMail As Object
  81.     Dim xCell As Range
  82.     Dim xRg As Range
  83.     Dim xTxt As String
  84.     On Error Resume Next
  85.     xTxt = ActiveWindow.RangeSelection.Address
  86.     Set OutApp = CreateObject("Outlook.Application")
  87.     Set OutMail = OutApp.CreateItem(0)
  88.     Set xRg = Application.InputBox("Please select the data range:", "Excel", xTxt, , , , , 8)
  89.     If xRg Is Nothing Then Exit Sub
  90.     If xRg.Columns.Count <> 7 Then
  91.         MsgBox "ERROR: Range je presiahnutý alebo zle zadaný.", , "Excel"
  92.         Exit Sub
  93.     End If
  94.    
  95.     For i = 1 To xRg.Rows.Count
  96. '       Get the email address
  97.        'xEmail = xRg.Cells(i, 7) V prípade že chceš si zautomatizova zasielanie mailu tak treba odkomentova tuto line.
  98. '       Message subject
  99.        xSubj = "Vyhodnotenie mentoringu p. " & xRg.Cells(i, 2) & " "
  100. '       Compose the message
  101.        'xMsg = ""
  102.        'xMsg = xMsg & "<body style = ""font-size:11pt;font-family: Calibri"">Dobrý deò p. <b>" & xRg.Cells(i, 6) & "</b>," & vbCrLf & vbCrLf
  103.        'xMsg = xMsg & " v rámci blížiaceho sa vyhodnotenia mentoringu p. "
  104.        'xMsg = xMsg & xRg.Cells(i, 2).Text & " Vám posielam hodnotiace dotazníky, jednak pre nového kolegu/kolegyòu  p. " & xRg.Cells(i, 2).Text & " (Dotmentor_zamest_new_Corporate) a pre mentora p. " & xRg.Cells(i, 4).Text & " (Sprmentora_new_Corporate + Mentoring Check List - tu prosím doplni, èo sa zrealizovalo). " & vbCrLf
  105.        'xMsg = xMsg & "Prosím o ich distribúciu jednotlivým kolegom. " & vbCrLf & vbCrLf
  106.        'xMsg = xMsg & " Vyplnené materiály v tlaèenej forme, prosím, doruète Ivke Hanuštiakovej, ktorá zabezpeèí podpísanie p. Srncom. " & vbCrLf & vbCrLf
  107.        'xMsg = xMsg & " Vyplnené dotazníky a check list mi prosím pošlite (sken mailom) spolu s Vašim hodnotením mentoringu (postaèuje pár slovami do mailu) a spolu s odporúèaním na vyplatenie mentorskej odmeny pre p. " & xRg.Cells(i, 4).Text & " vo výške 33,33,- Eur / 1 mesiac mentoringu, èiže za tri mesiace je to 100,- Eur (taktiež postaèí do mailu)." & vbCrLf & vbCrLf
  108.        'xMsg = xMsg & " V prípade akýchko¾vek otázok ma prosím kontaktujte." & vbCrLf & vbCrLf
  109.        'xMsg = xMsg & " Prajem príjemný deò " & vbCrLf & vbCrLf
  110.        'xMsg = xMsg & "René Bergmann  " & vbCrLf
  111.        'xMsg = xMsg & "Vedúci tímu Vzdel.a rozvoj HQ a FOS " & vbCrLf
  112.        'xMsg = xMsg & "Vlárska 48, 821 01 Bratislava " & vbCrLf
  113.        'xMsg = xMsg & "Tel.: +421 904 750 134 " & vbCrLf
  114.        'xMsg = xMsg & "E -mail: rbergmann@ vub.sk</body>" & vbCrLf
  115.        If uvod = 0 Then
  116.             xMsg = "" & _
  117.                 "<body style = ""font-size:11pt;font-family: Calibri"">Dobrý deò p. <b>" & xRg.Cells(i, 6) & "</b>,<br><br>" & _
  118.                 " <b>v rámci blížiaceho sa vyhodnotenia mentoringu p. <font color = ""#3860a0"">" & _
  119.                 xRg.Cells(i, 2).Text & "</font></b> Vám posielam <b>hodnotiace dotazníky</b>, jednak pre nového kolegu/kolegyòu  p. <b><font color = ""#3860a0"">" & xRg.Cells(i, 2).Text & "</font></b> (Dotmentor_zamest_new_Corporate) a pre mentora p. <b><font color = ""#3860a0"">" & xRg.Cells(i, 4).Text & "</font></b> (Sprmentora_new_Corporate + Mentoring Check List - tu prosím doplni, èo sa zrealizovalo). <br>" & _
  120.                 "Prosím o ich distribúciu jednotlivým kolegom. <br><br>" & _
  121.                 " Vyplnené materiály <b>v tlaèenej forme, prosím, doruète Ivke Hanuštiakovej</b>, ktorá zabezpeèí podpísanie p. Srncom. <br><br>" & _
  122.                 " Vyplnené dotazníky a check list mi prosím pošlite (sken mailom) spolu s Vašim hodnotením mentoringu (postaèuje pár slovami do mailu) a spolu s odporúèaním na vyplatenie mentorskej odmeny pre p. <b><font color = ""#3860a0"">" & xRg.Cells(i, 4).Text & "</font></b> vo výške 33,33,- Eur / 1 mesiac mentoringu, èiže za tri mesiace je to 100,- Eur (taktiež postaèí do mailu).<br><br>" & _
  123.                 " V prípade akýchko¾vek otázok ma prosím kontaktujte.<br><br>" & _
  124.                 " Prajem príjemný deò.<br><br>" & _
  125.                 "<font color = ""#3860a0""><b>René Bergmann</b><br>" & _
  126.                 "Vedúci tímu Vzdel. a rozvoj HQ a FOS <br>" & _
  127.                 "Vlárska 48, 821 01 Bratislava <br>" & _
  128.                 "Tel.: +421 904 750 134 <br>" & _
  129.                 "E -mail: rbergmann@vub.sk<br><img src = ""Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\vublogo.gif""></font></body>"
  130.         Else
  131.             xMsg = "" & _
  132.                 "<body style = ""font-size:11pt;font-family: Calibri"">Dobrý deò p. <b>" & xRg.Cells(i, 6) & "</b>,<br><br>" & _
  133.                 "nako¾ko ste boli Vašim riadite¾om FOC <b>nominovaný na pozíciu mentora pre p. " & xRg.Cells(i, 4) & "</b> , ktorá nastúpila na pozíciu MKV dòa " & xRg.Cells(i, 1) & ", rád by som Vás prostredníctvom tohto emailu oboznámil s cie¾om mentoringu, obsahom, základnými dokumentmi, Vašimi úlohami a odmenou. <br><br>" & _
  134.                 "<b>Cie¾om programu mentoringu</b> je zabezpeèi plynulú a bezproblémovú adaptáciu nového zamestnanca do banky tak, aby sa èo najskôr stal plnohodnotným èlenom tímu.<br><br>" & _
  135.                 "<b>Vašou úlohou bude</b> pomôc novému zamestnancovi v jeho úspešnej adaptácii, a to nielen do pracovného, ale aj sociálneho prostredia firemnej poboèky. V prílohe prikladám pomôcky pre Vás a nového zamestnanca: <b>Individuálny rozvojový plán a Mentoring checklist.</b> Oba dokumenty sme aktualizovali vzh¾adom k reálnym potrebám nových zamestnancov. Prosím, venujte im pozornos a budem rád aj za spätnú väzbu (návrhy na ich zlepšenie).<br><br>" & _
  136.                 "<b>Adaptaèná príprava a školenia:</b>" & _
  137.                 "Credit Risk základy:  -  po vypísaní termínu kolegyòa obdrží pozvánku z Akadémie VUB (následne je potrebné akceptova kalendárovú položku).<br>" & _
  138.                 "Insights farebná typológia prebehne  a  Insights vyjednávanie - <b>kolega/<font color = ""#3860a0"">kolegyòa</font> dostane informáciu o termíne prostredníctvom akadémie po stanovení termínu.</b><br>" & _
  139.                 "Corporate I. a Corporate II  - <b><font color = ""#ffcc00"">Corporate I.</font> - <font color = ""#3860a0"">termín zatia¾ nie je stanovený ,</font> <font color = ""#ffcc00"">Corporate II.</font> - <font color = ""#3860a0"">termín zatia¾ nie je stanovený.</font></b><br>" & _
  140.                 "Pozvánky prídu zamestnancovi z Akadémie VUB v dostatoènom predstihu pred školením.<br><br>" & _
  141.                 "<b>Odmena mentora</b> je stanovená vo výške 33,- Eur na mesiac/jedného nového zamestnanca a bude Vám vyplatená po skonèení skúšobnej doby zamestnanca s podmienkou, aby ste po ukonèení Vy aj mentorovaný vyplnili dotazníky na vyhodnotenie mentoringu. Dotazníky pošlem riadite¾ovi FOC po ukonèení skúšobnej doby. Súèasou dotazníkov bude aj vyplnený Checklist, preto ho prosím vypåòajte priebežne.<br><br>" & _
  142.                 "V prípade otázok ma prosím kontaktujte. <br><br><br>" & _
  143.                 "<font color = ""#3860a0""><b>René Bergmann</b><br>" & _
  144.                 "Vedúci tímu Vzdel. a rozvoj HQ a FOS <br>" & _
  145.                 "Vlárska 48, 821 01 Bratislava <br>" & _
  146.                 "Tel.: +421 904 750 134 <br>" & _
  147.                 "E -mail: rbergmann@vub.sk<br><img src = ""Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\vublogo.gif""></font></body>"
  148.         End If
  149.        
  150. '       Replace spaces with %20 (hex)
  151.        'xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
  152.        'xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
  153. '       Replace carriage returns with %0D%0A (hex)
  154.        'xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
  155. '       Create the URL
  156.        'xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
  157. '       Execute the URL (start the email client)
  158.        'ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
  159. '       Wait two seconds before sending keystrokes
  160.  
  161.         With OutMail
  162.             .To = "" 'treba zmenit na svoj mail pri testovani
  163.            .CC = ""
  164.             .BCC = ""
  165.             .Subject = xSubj
  166.             .HTMLBody = xMsg
  167.             If uvod = 0 Then
  168.                 .Attachments.Add ("Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\Dotmentor_zamest_new_Corporate.doc")
  169.                 .Attachments.Add ("Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\Nový_Check_list_a_prílohy.xls")
  170.                 .Attachments.Add ("Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\Sprmentora_new_Corporate.doc")
  171.             Else
  172.                 .Attachments.Add ("Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\Nový Check list a prílohy.xls")
  173.                 .Attachments.Add ("Z:\Tim L´n´D HQ+FOS\Adaptacka SME\Mentoring\HarkyPreMakro\Indiv.rozv. plan.xls")
  174.             End If
  175.             .Display (True)  'or use .Display
  176.            'Rozdiel medzi .Display a .Send je ten že .Display najprv ukáže formu a po dvoch-troch sekundách zašle mail, kým .Send ho iba pošle a niè neukáže.
  177.        End With
  178.        
  179.         Set OutMail = Nothing
  180.         Set OutApp = Nothing
  181.            
  182.         Application.Wait (Now + TimeValue("0:00:02"))
  183.         Application.SendKeys "%s"
  184.        
  185.         MsgBox "DEBUG: Forma vytvorená a prezentovaná.", , "Excel"
  186.     Next
  187. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!