• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

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)

Zaslat odpověď >

---

dream2003(27.5.2014 20:45)#019705

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

jaks.dalibor(27.5.2014 20:51)#019706

dream2003, nějak nechápu citovat

dream2003(27.5.2014 20:54)#019707

myslel jsem že to co tam máš vytvořeno ti funguje a chceš ošetřit aby ti to nespustily lidi dvakrátcitovat

jaks.dalibor(27.5.2014 21:03)#019708

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

dream2003(27.5.2014 21:19)#019709

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

jaks.dalibor(27.5.2014 22:00)#019710

díky, tak tím se musím prohrabat, mám tam trochu jiný sloupce. citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse