viděl bych to stávájící makro hodit do modulu a poté vymazat modul viz
http://wall.cz/index.php?m=topic&id=5237citovat
http://wall.cz/index.php?m=topic&id=5237citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: termíny z excelu do outlooku
MS Excel
Téma: termíny z excelu do outlooku 
Zaslal/a jaks.dalibor 27.5.2014 19:40
čau všichni, mám rozdělaný ještě jeden projekt, se kterým se trápím. Tvořím lhůtník, kde bych potřeboval pomocí tlačítka přenést lhůty revizí a kontrol do kalendáře outlook (nebo úkoly - nevím co je lepší). ještě bych možná dokázal od někoho předělat kod na nahrání termínů, ale nezabráním, aby po opětovném stisku tlačítka se mi to tam nevložilo podruhé (a znáte lidi, "mačkám, mačkám, co to dá 
"). Nějaká help? 
Příloha: 
19703_lhutnik.rar (15kB, staženo 25x)
19703_lhutnik.rar (15kB, staženo 25x)dream2003, nějak nechápu 
citovat
citovatmyslel jsem že to co tam máš vytvořeno ti funguje a chceš ošetřit aby ti to nespustily lidi dvakrátcitovat
aha, už jsem to pochopil. Zatím tam nemám vytvořeno nic, navíc by to mělo fungovat i tak, že ty termíny se budou dost měnit, takže to tlačítko potřebuju s aktivním makrem.citovat
zkus toto nemám přístup k utlouku
Option Explicit
Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTIme As Double, dReminder As Double, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
For r = 2 To 10
If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then Goto NextRow
sSubject = Sheet1.Cells(r, 2).Value
sBody = Sheet1.Cells(r, 5).Value
dStartTime = Sheet1.Cells(r, 1).Value
dEndTIme = Sheet1.Cells(r, 4).Value
sLocation = Sheet1.Cells(r, 6).Value
dReminder = 120
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.Duration = dEndTIme
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
citovat
Option Explicit
Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTIme As Double, dReminder As Double, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
For r = 2 To 10
If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then Goto NextRow
sSubject = Sheet1.Cells(r, 2).Value
sBody = Sheet1.Cells(r, 5).Value
dStartTime = Sheet1.Cells(r, 1).Value
dEndTIme = Sheet1.Cells(r, 4).Value
sLocation = Sheet1.Cells(r, 6).Value
dReminder = 120
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.Duration = dEndTIme
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
citovat
díky, tak tím se musím prohrabat, mám tam trochu jiný sloupce. 
citovat
citovatUživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články