Exportar a Excel CSV exporta contactos a Archivo Excel csv
CONST sFullFielName = ""
'Modo de apertura del archivo csv
CONST ForReading = 1, ForWriting = 2, ForAppending = 8
'Columnas que se sincronizan
CONST sColumns = "EMAIL1,DISPLAYNAME,NAME,SURNAME,ORGANIZATION,REGION,TELEPHONE,OTHERPHONE,MOBILE,HOMESTREET,DOC_ID"
CONST sColumnsExch = "DocId,ExternalEmailAddress,DisplayName,FirstName,LastName,ORGANIZATION,StateOrProvince,Phone,OtherTelephone,MobilePhone,StreetAddress,Name"
CONST sDirectoryFileRepository = "C:\Program Files (x86)\Gestar\web\crm\contacts"
'Session global
Dim oFolderContacts
Dim iLimitPage : iLimitPage = 100
set fld = dSession.FoldersGetFromid(2403)
SyncAllContacts fld
'Sync all contacts
Function SyncAllContacts(Folder)
Set dSession = Folder.Session
'Dim oDom : Set oDom = Folder.Search(sColumns&"","contactType=0","")
Dim sFullExporFileName : sFullExporFileName = "SyncAll_" & GetDateString() & ".csv"
CreatetCSVFile sFullExporFileName, sColumnsExch,ForWriting
Set oFolderContacts = Folder ' dSession.FoldersGetfromid(2403)
Dim bContinueFlag : bContinueFlag = True
Dim oDomToProcess
Dim lastDocId : lastDocId = "0"
Dim iCounter :iCounter = 0
Do While bContinueFlag
Set oDomToProcess = GetPartialDom(lastDocId,bContinueFlag)
If Not bContinueFlag Then
Exit Do
End If
Dim sVal : sVal = GetValues(oDomToProcess)
CreatetCSVFile sFullExporFileName, sVal,ForAppending
iCounter = iCounter + 1
dSession.DebugPrint "counter " & iCounter
Loop
SyncAllContacts = 0
End Function
'Sync modified contact
Function SyncModifyContact(Doc)
Set dSession = Doc.Parent.Session
Dim oDom : Set oDom = Doc.Parent.Search(sColumns&"","contactType=0 and doc_id="&Doc.id,"")
Dim sFullExporFileName : sFullExporFileName = "SyncModify_" & GetDateString() & ".csv"
CreatetCSVFile sFullExporFileName, sColumnsExch,ForWriting
Dim sVal : sVal = GetValues(oDom)
CreatetCSVFile sFullExporFileName, sVal,ForAppending
RunPowerSehll sFullExporFileName
DeleteCSVFile sFullExporFileName
SyncModifyContact = oDom.documentElement.childNodes.length
End Function
'Coming soon
Function SyncDeleteContact(Doc)
Set dSession = Doc.Parent.Session
SyncDeleteContact = 1
End Function
'*********************************************
'Helpper Methods
'*********************************************
'Retrieve partial Dom using iLimitPage like limit
Function GetPartialDom(lastDocId,bContinueFlag)
Dim sFilter : sFilter = "contactType = 0 and doc_id > " & lastDocId
Set oDom = oFolderContacts.Search(sColumns&"",sFilter&"","doc_id",iLimitPage&"")
If oDom.documentElement.ChildNodes.length &"" = iLimitPage &"" Then
lastDocId = oDom.documentElement.ChildNodes(oDom.documentElement.ChildNodes.length-1).getAttribute("doc_id")&""
Else
lastDocId=""
bContinueFlag = False
End If
Set GetPartialDom = oDom
End Function
'Gets values from csv body document
Function GetValues(oDom)
Dim sValues : sValues =""
Dim arrCol : arrCol = split(sColumns,",")
Dim i,oNode
Dim iCount
Dim sFinalValue
Dim iTotalCount : iTotalCount = oDom.documentElement.ChildNodes.length
for each oNode in oDom.documentElement.ChildNodes
iCount = iCount +1
For i = 0 To Ubound(arrCol)
if sValues & "" <> "" Then
sValues = sValues & ","
End if
dim sVal :sVal = Trim(oNode.getAttribute(LCASE(arrCol(i)&""))&"")
'dSession.debugPrint "nombre: " & LCASE(arrCol(i)&"") & " valor: " & Trim(oNode.getAttribute(LCASE(arrCol(i)&""))&"")
if sVal& "" ="" Then sVal = "-"
sValues = sValues & """" & sVal &""""
Next
if iCount < iTotalCount Then
sFinalValue = sFinalValue & sValues & "" & vbNewline
'sValues = sValues & "" & vbNewline
End if
sValues = ""
next
GetValues = sFinalValue
End Function
'Procedimiento de creacion del archivo CSV
'Se utiliza para crear el archivo, agregar sus columnas y tambien sus valores, en modo append.
Sub CreatetCSVFile(sFullFileName,sValues,iMode)
Dim filesys
On Error Resume Next
Set filesys = CreateObject("Scripting.FileSystemObject")
Dim sPath : sPath = sDirectoryFileRepository & "/" &sFullFileName
Set filetxt = filesys.OpenTextFile(sPath, iMode, True)
filetxt.WriteLine(sValues)
filetxt.Close
If err.number <> 0 Then
dSession.ErrRaise "*Creacion o Agregado CSV: " & cntModulo & " sPath: " & sPath &" Error: " & err.number & " description: " & err.description
End if
On Error GoTo 0
End Sub
'Procedimiento de borrado del archivo CSV
'Si la ejecucion de syncro es correcta se elimina el archivo
Sub DeleteCSVFile(sFullFileName)
Dim filesys
On Error Resume Next
Set filesys = CreateObject("Scripting.FileSystemObject")
Dim sPath : sPath = sDirectoryFileRepository & "/" &sFullFileName
filesys.DeleteFile(sPath)
If err.number <> 0 Then
dSession.ErrRaise "*Borrado de CSV: " & cntModulo & " sPath: " & sPath & " Error: " & err.number & " description: " & err.description
End if
On Error GoTo 0
End Sub
Function ScriptControl(Timeout)
Dim oSC
Set oSC = CreateObject("ScriptControl")
With oSC
.Language = "VBScript"
.AllowUI = False
.Timeout = Timeout
End With
Set ScriptControl = oSC
End Function
Function RunPowerSehll(sFileName)
On error Resume Next
Dim iResult : iResult = 0
Set objShell = CreateObject("Wscript.shell")
'dim sCommand : sCommand = "powershell -noexit -ExecutionPolicy RemoteSigned -file """ & sDirectoryFileRepository &"\ImportContacts.ps1"" -csvFileName """ & sDirectoryFileRepository & "/" &sFileName&""""
dim sCommand : sCommand = "powershell -ExecutionPolicy RemoteSigned -file """ & sDirectoryFileRepository &"\ImportContactsMail.ps1"" -csvFileName """ & sDirectoryFileRepository & "/" &sFileName&""""
dSession.debugPrint " PRES " & sCommand
'Llama al procedimiento que conecta con el exchange y sincroniza el CSV creado
' 1 Parametro: comando a ejecutar
' 2 Parametro: implcia que no se abre ninguna ventana de powershell es modo silent.
' 3 Parametro: la llamada es sincrona, es decir el scripting espera el fin de ejecucion
objShell.run sCommand,0,True
if err.number &""<> "0" Then
dSession.debugPrint " *ERROR: " & cntModulo & " RunPowerShell file: " &sFileName
dSession.debugPrint " Err.Number : " & Err.Number
dSession.debugPrint " Err.Description : " & Err.Description
iResult = 1
else
dSession.debugPrint " Ejecucion de syncronizacion de contactos correcta. " & sCommand
End if
Set objShell= nothing
On error GoTo 0
RunPowerSehll = iResult
End Function
'Return Date as String
Function GetDateString()
Dim dNow : dNow = Now
Dim sDateValue : sDateValue = DatePArt("d",dNow)&""&datePart("m",dNow)&""&datePart("yyyy",dNow)&""&DatePart("h", dNow)&""&DatePart("n", dNow)&""&DatePart("s", dNow)
GetDateString = sDateValue
End Function