SELF Solved: outlook sync from excel

[cdkeito]

hi all,

a litle question:

how do you make outlook to start posting yours email after the well know .send or .display (sendkeys "%s")?
I presume something like this:

Dim colSyncObjects As Outlook.SyncObjects
Dim objSyncObject As Outlook.SyncObject

Sub StartSync()
   Set colSyncObjects = Session.SyncObjects
   Set objSyncObject = colSyncObjects("All Folders")
   objSyncObject.Start
End Sub

I start with outlook closed (only excel).
(If i's not clear, I'm interested in the START metod)

 

[Zack Barresse]

Well, if you want to use the SendKeys method then you can use ..


<font face=Tahoma New> <SPAN style="color:#00007F">Function</SPAN> Mail_Outlook(ind <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>)
    <SPAN style="color:#00007F">Dim</SPAN> OutApp <SPAN style="color:#00007F">As</SPAN> Outlook.Application
    <SPAN style="color:#00007F">Dim</SPAN> OutMail <SPAN style="color:#00007F">As</SPAN> Outlook.MailItem
    <SPAN style="color:#00007F">Dim</SPAN> strDate <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, DefPath <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, FileNameZip <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>
    strDate = "Elaborati"
    DefPath = ThisWorkbook.Path
    <SPAN style="color:#00007F">If</SPAN> Right(DefPath, 1) <> "\" <SPAN style="color:#00007F">Then</SPAN>
        DefPath = DefPath & "\"
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
    FileNameZip = DefPath & strDate & ".zip"
    <SPAN style="color:#007F00">'should check if "FileNameZip" is valid file here...</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> OutApp = CreateObject("Outlook.Application")
    <SPAN style="color:#00007F">Set</SPAN> OutMail = OutApp.CreateItem(olMailItem)
        <SPAN style="color:#00007F">With</SPAN> OutMail
            .To = ind
            .Subject = "CLIENTI ATTIVI"
            .Body = "regalo"
            .Attachments.Add FileNameZip
            .Display
            Application.Wait (Now + TimeValue("0:00:02"))
            Application.SendKeys "%s"  <SPAN style="color:#007F00">' send</SPAN>
        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
        Kill FileNameZip
    <SPAN style="color:#00007F">Set</SPAN> OutMail = <SPAN style="color:#00007F">Nothing</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> OutApp = <SPAN style="color:#00007F">Nothing</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN>

<SPAN style="color:#00007F">Sub</SPAN> TestIt()
    Mail_Outlook "somebody@domain.com"
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>


You almost had it.

 

[cdkeito]

But its the same function, it lack in the same thing:
it doesn't make outlook start the mails syncronize!!!

I'm looking for something like:

 Function Mail_Outlook(ind As String)
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strDate As String, DefPath As String, FileNameZip As String
    strDate = "Elaborati"
    DefPath = ThisWorkbook.Path
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    FileNameZip = DefPath & strDate & ".zip"
    'should check if "FileNameZip" is valid file here...
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
        With OutMail
            .To = ind
            .Subject = "CLIENTI ATTIVI"
            .Body = "regalo"
            .Attachments.Add FileNameZip
            .Display
            Application.Wait (Now + TimeValue("0:00:02"))
            Application.SendKeys "%a"  ' send  my language
        End With
        Kill FileNameZip
    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Sub main()     '  <<<<<<<<<<<<<<<<<<<<<<<<
    ' ...
    for each r in range(a1:a100)  ' for  example
    Mail_Outlook(r.text)
    next
    call sync_sync      '  or    call desperate_sync    
    ' see below for those two routine
    ' ...
End Sub 

Sub sync_sync()
Dim OLSyncs As Outlook.SyncObjects
Dim OLSync As Outlook.SyncObject
Set OLApp = CreateObject("Outlook.Application")
Set OLMAPI = OLApp.Getnamespace("MAPI")
Set OLSyncs = OLMAPI.SyncObjects
For i=1 to OLSyncs.count
OLSyncs.Item(i).start
next
Set OLSync = nothing
Set OLSyncs = nothing
Set OLMAPI = nothing
Set OLApp = nothing
End Sub

Sub desperate_sync()
Dim OutApp As Outlook.Application
Set OutApp = CreateObject("Outlook.Application")
OutApp.visible = True   ' <<<<<<<here it don't work
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "{F9}" ' send & receive 
Application.Wait (Now + TimeValue("0:00:02"))
Set OutApp = Nothing
End Sub

 

[cdkeito]

What I realy need is a working version for:
sync_sync()
or, at least:
desperate_sync()

GRAZIEEEEEEEEEEEEEEEE.

 

[cdkeito]

thanks for the help.

 

[Zack Barresse]

I'm not sure if it's impossible or not, you only gave it a single day before coming to that conclusion (after the previous post). I haven't had much time lately, but will try to get through your code soon, but might be until next week as I am extremely busy. Hopefully somebody else will pick this up. If not, shoot me a pm next week and I'll do my best.

 

[cdkeito]

you'ra a god man

 

[cdkeito]

Thanks all guys.

I've solved it on my on.

Sub Sync()
    Dim nsp As Outlook.Namespace
    Dim sycs As Outlook.SyncObjects
    Dim syc As Outlook.SyncObject
    Dim i As Integer
    Dim strPrompt As Integer
    Set OLApp = CreateObject("Outlook.Application")
    Set nsp = OLApp.GetNamespace("MAPI")
    Set sycs = nsp.SyncObjects
    For i = 1 To sycs.Count
        Set syc = sycs.Item(i)
        syc.Start
    Next
End Sub

 

[Zack Barresse]

cdkeito, glad to see you got it solved on your own! Apologies for not working on this sooner, been very busy. So nice of you to post your solution!

Happy holidays!

 

[cdkeito]

in the meantime I've also writed this monster:

Sub start()

    Application.ScreenUpdating = False
    Set ws1 = Sheets("Start")
    Set rngx = ws1.Range("a2", ws1.Range("a65536").End(xlUp))
    For Each rx In rngx
        rx.NumberFormat = "0000"
        rx.Value = "'" & Right("0000" & rx.Text, 4) & ""
    Next
    
    Script = "'Generato il " & Date & vbNewLine & vbNewLine
    
    Script = Script & "Set objFSO = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")" & vbNewLine
    
    Script = Script & "If Not objFSO.FolderExists(" & Chr(34) & ActiveWorkbook.Path & "\Cartelle_Rete" & Chr(34) & ") Then" & vbNewLine
    Script = Script & "Set objFolder = objFSO.CreateFolder(" & Chr(34) & ActiveWorkbook.Path & "\Cartelle_Rete" & Chr(34) & ")" & vbNewLine
    Script = Script & "End If" & vbNewLine

    '_______________________________________________________________________
    
    For Each rx In rngx
        mainpath = ActiveWorkbook.Path & "\Cartelle_Rete"
        Dop = rx.Offset(, 1).Text
        Filiale = rx.Offset(, 2).Text
        
        mainpath = mainpath & "\" & Dop
        Script = Script & "If Not objFSO.FolderExists(" & Chr(34) & mainpath & Chr(34) & ") Then" & vbNewLine
        Script = Script & "Set objFolder = objFSO.CreateFolder(" & Chr(34) & mainpath & Chr(34) & ")" & vbNewLine
        Script = Script & "End If" & vbNewLine
        mainpath = mainpath & "\" & Filiale
        Script = Script & "If Not objFSO.FolderExists(" & Chr(34) & mainpath & Chr(34) & ") Then" & vbNewLine
        Script = Script & "Set objFolder = objFSO.CreateFolder(" & Chr(34) & mainpath & Chr(34) & ")" & vbNewLine
        Script = Script & "End If" & vbNewLine
        Script = Script & "If Not objFSO.FolderExists(" & Chr(34) & mainpath & "\Fatturazione" & Chr(34) & ") Then" & vbNewLine
        Script = Script & "Set objFolder = objFSO.CreateFolder(" & Chr(34) & mainpath & "\" & "Fatturazione" & Chr(34) & ")" & vbNewLine
        Script = Script & "End If" & vbNewLine
        Script = Script & "If Not objFSO.FolderExists(" & Chr(34) & mainpath & "\Fatturazione\Note di Credito" & Chr(34) & ") Then" & vbNewLine
        Script = Script & "Set objFolder = objFSO.CreateFolder(" & Chr(34) & mainpath & "\Fatturazione\Note di Credito" & Chr(34) & ")" & vbNewLine
        Script = Script & "End If" & vbNewLine
        Script = Script & "If Not objFSO.FolderExists(" & Chr(34) & mainpath & "\Fatturazione\Note di Debito" & Chr(34) & ") Then" & vbNewLine
        Script = Script & "Set objFolder = objFSO.CreateFolder(" & Chr(34) & mainpath & "\Fatturazione\Note di Debito" & Chr(34) & ")" & vbNewLine
        Script = Script & "End If" & vbNewLine
        
    Next
    
    '_______________________________________________________________________
    
    Open ActiveWorkbook.Path & "\CartelleRete.vbs" For Output As #1
    Print #1, Script  ' Script = string with the script to write
    Close #1

End Sub

and it worked on the 1ft try.