Hallo alle mit einander, vielleicht könnt ihn mir ja helfen.
Ich arbeite mich in einen fremden Quellcode ein. Die Daten werden aus der Datenbank geholt und in Outlook als Kontakte eintragen nur wenn ich was ändere werde immer weniger Daten übertragen vielleicht könnt ihr mir ja helfen. Wo geändert steht da war ich bei.
Option Explicit
' Declare enum for all scipt
Dim adUseClient '= 3
Dim adOpenStatic '= 3
Dim adLockReadOnly '= 1
Dim adCmdText '= 1
Dim adModeReadWrite '= 3
Dim adCreateOverwrite '= 0x4000000
Dim adDelayFetchFields '= 0x8000
Dim adStateOpen '= 1
Dim rc
Dim ZeitStart
adUseClient = 3
adOpenStatic = 3
adLockReadOnly = 1
adCmdText = 1
adModeReadWrite = 3
adCreateOverwrite = 67108864
adDelayFetchFields = 32768
adStateOpen = 1
Public Sub Kontakt_Add()
'On Error Resume Next
Dim objCnnSource 'As ADODB.Connection ' connection to the source data
Dim objRstSource 'As ADODB.Recordset ' recordset to store souce data
DIM objRstAditoDeaktiv, strSQLAditoDeaktiv, objSQLAditoSource
Dim strSqlSource 'As String
Dim objCnnTargetFull 'As ADODB.Connection
Dim objCnnTargetPart 'As ADODB.Connection
Dim strURL_Full 'As String
Dim strURL_Part 'As String
Dim strTemp 'As String
Dim strBody 'As String
Dim strUrlTarget 'As String
Dim strUrlTargetFull 'As String
Dim strUrlTargetPart 'As String
Dim intCnt 'As Integer
Dim strMSSQL
Dim ZZZ, sSQL, sURL, WHEREAID
Dim oRst, oRec
Dim DayNow,DayOfWeekDelete,NumberOfWeekDelete,TodayIsTheDay
Dim DaysBack, IDsDeaktiv,MaxRecords
DayNow=now
'---statische Einstellungen
'DayNow=#09/25/2004# 'zum testen
'MaxRecords=250
DaysBack=48 'Wieviel Tage neu lesen
DayOfWeekDelete = 7 'Samstag
NumberOfWeekDelete = 3 ' 3te Woche im Monat
strSqlSource = "SELECT * FROM VIEW_EXCHANGE WHERE (FADeaktiv = 'FF')"
strSQLAditoDeaktiv= "SELECT AID FROM VIEW_EXCHANGE WHERE (FADeaktiv = 'WW' OR FADeaktiv = 'FW' OR FADeaktiv = 'WF' )"
strMSSQL = "Provider='sqloledb';Data Source='SVR-12';Initial Catalog= 'Inros_Daten';Integrated Security=SSPI"
strURL_Full = "http://SVR-04/public/Adito-Adressen/"
'---dynamische Einstellungen
if (day(DayNow)\7 = NumberOfWeekDelete AND weekday(DayNow) = DayOfWeekDelete) then
TodayIsTheDay=true
else
TodayIsTheDay=false
end if
'---Connect to SQL source to get customer information
if not TodayIsTheDay then
strSqlSource = strSqlSource & " AND ( ( FDatumEdit between DATEADD(day, -"&DaysBack&", getdate()) and getdate() ) OR ( ADatumEdit between DATEADD(day, -"&DaysBack&", getdate()) and getdate() ) OR ( MDatumEdit between DATEADD(day, -"&DaysBack&", getdate()) and getdate() ) OR ( FDatumNeu between DATEADD(day, -"&DaysBack&", getdate()) and getdate() ) OR ( ADatumNeu between DATEADD(day, -"&DaysBack&", getdate()) and getdate() ) )"
end if
' Clear Err object to trap only errors in creation of dataconnection
If Err.Number <> 0 then
Err.Clear
End If
Set objCnnSource = CreateObject("ADODB.Connection") ' create connection to connect to ODBC datasource
Set objRstSource = CreateObject("ADODB.Recordset") ' create recordset to get data from ODBC datasource
Set objRstAditoDeaktiv = CreateObject("ADODB.Recordset") ' create recordset to get data from ODBC datasource
objCnnSource.ConnectionString = strMSSQL 'User ID='AditoToExchange';Password='ATE';"
objCnnSource.CursorLocation = adUseClient
objCnnSource.Open ' open a connection
' Error handler
If Err.Number <> 0 Then
If objCnnSource.State = adStateOpen Then
objCnnSource.Close
End If
Set objCnnSource = Nothing
WScript.Echo "Cannot connect to the datasource"
Exit Sub
End If
' Clear Err object to trap only errors in connecting to recordset
If Err.Number <> 0 then
Err.Clear
End If
objRstSource.CursorLocation = adUseClient
objRstSource.Open strSqlSource, objCnnSource, adOpenStatic, adLockReadOnly, adCmdText
objRstAditoDeaktiv.Open strSQLAditoDeaktiv, objCnnSource, adOpenStatic, adLockReadOnly, adCmdText
If Err.Number <> 0 Then
If objRstSource.State = adStateOpen Then
objRstSource.Close
End If
If objCnnSource.State = adStateOpen Then
objCnnSource.Close
End If
If objRstAditoDeaktiv.State = adStateOpen Then
objRstAditoDeaktiv.Close
End If
Set objRstSource = Nothing
Set objCnnSource = Nothing
Set objRstAditoDeaktiv = Nothing
WScript.Echo "Cannot connect to the datasource"
Exit Sub
End If
ZZZ=0
Do While Not objRstAditoDeaktiv.EOF
ZZZ=ZZZ+1
if WHEREAID <> "" then WHEREAID = WHEREAID & " OR "
WHEREAID = WHEREAID + " ""urn:schemas:contacts:customerid"" = '"& objRstAditoDeaktiv.Fields("AID").Value &"'"
IDsDeaktiv=IDsDeaktiv&", "&objRstAditoDeaktiv.Fields("AID").Value
objRstAditoDeaktiv.MoveNext
Loop
call Message(1,0,"AditoExchange","Deactivated ("&ZZZ&")","AID: "&IDsDeaktiv)
objRstAditoDeaktiv.close
'---Finished getting cutomer information,
'---Now checking and creating contacts in exchange target
' Clear Err object to trap only errors in connecting to public folder
If Err.Number <> 0 then
Err.Clear
End If
' set properties for the connection to the public folder
' Please consider to change the strURL when change the public folder
Set objCnnTargetFull = CreateObject("ADODB.Connection")
objCnnTargetFull.Provider = "ExOLEDB.DataSource"
objCnnTargetFull.Mode = adModeReadWrite
objCnnTargetFull.Open strURL_Full ' open a connection to the public folder to create data
' Error handler
If Err.Number <> 0 Then
If objRstSource.State = adStateOpen Then
objRstSource.Close
End If
If objCnnSource.State = adStateOpen Then
objCnnSource.Close
End If
Set objRstSource = Nothing
Set objCnnSource = Nothing
Set objCnnTargetFull = Nothing
WScript.Echo "Cannot connect to public folder"
Exit Sub
End If
'Von Dirk eingefügte Löschprozedur ...
Set oRec = CreateObject("ADODB.Record")
Set oRst = CreateObject("ADODB.Recordset")
oRec.Mode = adModeReadWrite
oRec.Open strURL_Full
'WScript.echo
if (day(DayNow)\7 = NumberOfWeekDelete AND weekday(DayNow) = DayOfWeekDelete) then
call Message(1,0,"AditoExchange","FullDelete Exchange","")
sSQL="select * from """&strURL_Full&""""
sSQL=sSQL & " WHERE "
sSQL=sSQL & "(""http://schemas.microsoft.com/exchange/outlookmessageclass"" != 'IPM.Microsoft.FolderDesign.FormsDescription')"
'strSqlSource = strSqlSource
else
call Message(1,0,"AditoExchange","PartDelete Exchange","")
sSQL="select * from """&strURL_Full&""""
sSQL=sSQL & " WHERE "
sSQL=sSQL & "(""http://schemas.microsoft.com/exchange/outlookmessageclass"" != 'IPM.Microsoft.FolderDesign.FormsDescription')"
sSQL=sSQL & " AND ( "
sSQL=sSQL & WHEREAID
sSQL=sSQL & " ) "
'strSqlSource = strSqlSource & " AND ( ( FDatumEdit between DATEADD(day, -32, getdate()) and getdate() ) OR ( ADatumEdit between DATEADD(day, -32, getdate()) and getdate() ) OR ( MDatumEdit between DATEADD(day, -32, getdate()) and getdate() ) OR ( FDatumNeu between DATEADD(day, -32, getdate()) and getdate() ) OR ( ADatumNeu between DATEADD(day, -32, getdate()) and getdate() ) )"
end if
oRst.Open sSQL,oRec.ActiveConnection
ZZZ=0
'For intCnt = 0 To oRst.Fields.Count - 1
' WScript.echo oRst.Fields(intCnt).Name&":"&oRst.Fields(intCnt).value
'Next
Do While Not oRst.EOF
' if oRst.Fields("http://schemas.microsoft.com/exchange/outlookmessageclass").Value <> "IPM.Microsoft.FolderDesign.FormsDescription" THEN oRst.Delete
ZZZ=ZZZ+1
if ((ZZZ+250) mod 250) = 0 then
'WScript.echo "AditoExchange: Delete ("&ZZZ&":"&oRst.Fields("urn:schemas:contacts:customerid").Value&"). "& ZeitStart & " -> " & Time
call Message(1,1,"AditoExchange","Delete ("&ZZZ&")","")
end if
oRst.Delete
oRst.MoveNext
Loop
oRst.close
if ZZZ>0 then call Message(1,1,"AditoExchange","DeleteFinish ("&ZZZ&")","")
ZZZ=0
'exit sub
' do the loop to copy data from datasouce to public folder
Do While Not objRstSource.EOF
' Create a part of file name
' The file name is created by combining company name, first name and name
strTemp = ""
If objRstSource.Fields("AName") <> "" Then strTemp = strTemp & objRstSource.Fields("AName") & " "
If objRstSource.Fields("AVorname") <> "" Then strTemp = strTemp & objRstSource.Fields("AVorname")
If objRstSource.Fields("FName") <> "" Then strTemp = strTemp & " (" & objRstSource.Fields("FName") & ")"
' Delete all special character from the file name to create a standard file name
strTemp = Replace(strTemp, Chr(34), "") ' "
strTemp = Replace(strTemp, Chr(44), "") ' ,
strTemp = Replace(strTemp, Chr(47), "") ' /
strTemp = Replace(strTemp, Chr(92), "") ' \'
strTemp = Replace(strTemp, Chr(58), "") ' :
strTemp = Replace(strTemp, Chr(42), "") ' *
strTemp = Replace(strTemp, Chr(63), "") ' ?
strTemp = Replace(strTemp, Chr(60), "") ' <
strTemp = Replace(strTemp, Chr(62), "") ' >
strTemp = Replace(strTemp, Chr(124), "") ' |
For intCnt = 0 To 31
strTemp = Replace(strTemp, Chr(intCnt), " ") ' special character
Next 'intCnt
strTemp = Replace(strTemp, Chr(127), " ") ' special character
strTemp = Replace(strTemp, Chr(129), " ") ' special character
strTemp = Replace(strTemp, Chr(141), " ") ' special character
strTemp = Replace(strTemp, Chr(143), " ") ' special character
strTemp = Replace(strTemp, Chr(144), " ") ' special character
strTemp = Replace(strTemp, Chr(157), " ") ' special character
' Create the complete file name including path to the public folder
strUrlTarget = ""
strUrlTargetFull = strURL_Full & right("000000" & objRstSource.Fields("AID").Value,6) & " " & strTemp & ".EML"
' Clear Err object to trap only errors in creation of contact item
If Err.Number <> 0 then
Err.Clear
End If
'--Create new record as a customer
Dim objRstTargetFull 'As ADODB.Record
Set objRstTargetFull = CreateObject("ADODB.Record")
objRstTargetFull.Open strUrlTargetFull, objCnnTargetFull, adModeReadWrite, adCreateOverwrite, adDelayFetchFields
' Error handler
If Err.Number <> 0 Then
If objRstSource.State = adStateOpen Then
objRstSource.Close
End If
If objCnnSource.State = adStateOpen Then
objCnnSource.Close
End If
If objCnnTargetFull.State = adStateOpen Then
objCnnTargetFull.Close
End If
Set objRstSource = Nothing
Set objCnnSource = Nothing
Set objCnnTargetFull = Nothing
WScript.Echo "Cannot connect to the datasource"
Exit Sub
End If
' Set record type (item type)
' Please consider to change the outlookmessageclass property when change the outlook form
objRstTargetFull.Fields.Item("DAV:contentclass").Value = "urn:content-classes:person"
objRstTargetFull.Fields.Item("http://schemas.microsoft.com/exchange/outlookmessageclass").Value = "IPM.Contact.Adito-Adressen-Formular"
objRstTargetFull.Fields.Item("urn:schemas:mailheader:subject").Value = strTemp
'objRstTargetFull.Fields.Update
'objRstTargetFull.Fields.Item("urn:schemas:contacts:mailingaddressid").Value ="2"
'geändert 6.12.04
If objRstSource.Fields("AAnrede") <> "" Then
objRstTargetFull.Fields("AAnrede").Value = objRstSource.Fields("AAnrede").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("ATitel") <> "" Then
objRstTargetFull.Fields("ATitel").Value = objRstSource.Fields("ATitel").Value
End If
'ende
'objRstTargetFull.Fields.Update
If objRstSource.Fields("AName") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:sn").Value = objRstSource.Fields("AName").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("AVorname") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:givenName").Value = objRstSource.Fields("AVorname").Value
End If
If objRstSource.Fields("FOrt") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:l").value = objRstSource.Fields("FOrt").Value
End If
If objRstSource.Fields("FPLZ") <> "" Then
'objRstTargetFull.Fields("urn:schemas:contacts:mailingpostalcode").Value = objRstSource.Fields("FPLZ").Value
objRstTargetFull.Fields("urn:schemas:contacts:postalcode").Value = objRstSource.Fields("FPLZ").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FNameLang") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:o").Value = objRstSource.Fields("FNameLang").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FName") <> "" Then
objRstTargetFull.Fields("FName").Value = objRstSource.Fields("FName").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FBranche") <> "" Then
objRstTargetFull.Fields("FBranche").Value = objRstSource.Fields("FBranche").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FStrasse") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:street").Value = objRstSource.Fields("FStrasse").Value
End If
If objRstSource.Fields("FPF") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:postofficebox").Value = objRstSource.Fields("FPF").Value
End If
'objRstTargetFull.Fields.Update
'geändert 8.12.04
If objRstSource.Fields("FPLZPF") <> "" Then
objRstTargetFull.Fields("FPLZPF").Value = objRstSource.Fields("FPLZPF").Value
End If
'ende
'geändert 8.12.04
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FTelefon") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:urn:schemas:contacts:secretaryphone").Value = objRstSource.Fields("FTelefon").Value
'urn:schemas:contacts:secretaryphone Haupttelefon
'urn:schemas:contacts:office2telephonenumber Telefon Geschäftlich 2
End If
'Ende
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FTelefax") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:facsimiletelephonenumber").Value = objRstSource.Fields("FTelefax").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FInternet") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:businesshomepage").Value = objRstSource.Fields("FInternet").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FEMail") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:email2").Value = objRstSource.Fields("FEMail").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FBundesland") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:st").Value = objRstSource.Fields("FBundesland").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("FTelefonMobil") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:mobile").Value = objRstSource.Fields("FTelefonMobil").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("AID") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:customerid").Value = objRstSource.Fields("AID").Value
End If
'geändert 3.12.04
'objRstTargetFull.Fields.Update
' If objRstSource.Fields("AName") <> "" OR objRstSource.Fields("AVorname") <> "" Then
' objRstTargetFull.Fields("urn:schemas:contacts:fileas").Value = objRstSource.Fields("AName").Value & " " & objRstSource.Fields("AVorname").Value
' End If
'ende
'geändert 6.12.04
'objRstTargetFull.Fields.Update
If objRstSource.Fields("ATelefon") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:telephoneNumber").Value = objRstSource.Fields("ATelefon").Value
End If
'ende
'objRstTargetFull.Fields.Update
If objRstSource.Fields("ATelefonMobil") <> "" Then
'If objRstSource.Fields("FTelefonMobil") = "" Then objRstTargetFull.Fields("urn:schemas:contacts:mobile").Value = objRstSource.Fields("ATelefonMobil").Value
objRstTargetFull.Fields("urn:schemas:contacts:telephonenumber2").Value = objRstSource.Fields("ATelefonMobil").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("ATelefax") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:otherfax").Value = objRstSource.Fields("ATelefax").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("AEMail") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:email1").Value = objRstSource.Fields("AEMail").Value
End If
'objRstTargetFull.Fields.Update
'Geändert 8.12.04
' If objRstSource.Fields("AEMail") <> "" Then
' objRstTargetFull.Fields("urn:schemas:contacts:email1").Value = objRstSource.Fields("AEMail").Value
'End If
'ende
'objRstTargetFull.Fields.Update
If objRstSource.Fields("APrivatStrasse") <> "" Then
'objRstTargetFull.Fields("urn:schemas:contacts:homepostaladdress").Value = objRstSource.Fields("APrivatStrasse").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("APrivatPLZ") <> "" Then
'objRstTargetFull.Fields("urn:schemas:contacts:homePostalCode").Value = objRstSource.Fields("APrivatPLZ").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("APrivatOrt") <> "" Then
'objRstTargetFull.Fields("urn:schemas:contacts:homeCity").Value = objRstSource.Fields("APrivatOrt").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("AFunktion") <> "" Then
objRstTargetFull.Fields("AFunktion").Value = objRstSource.Fields("AFunktion").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("AAbteilung") <> "" Then
objRstTargetFull.Fields("urn:schemas:contacts:department").Value = objRstSource.Fields("AAbteilung").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("ABriefanrede") <> "" Then
objRstTargetFull.Fields("ABriefanrede").Value = objRstSource.Fields("ABriefanrede").Value
End If
'objRstTargetFull.Fields.Update
If objRstSource.Fields("ABetreuerFachbereich") <> "" Then
objRstTargetFull.Fields("ABetreuerFachbereich").Value = objRstSource.Fields("ABetreuerFachbereich").Value
End If
'geändert 3.12.04
'objRstTargetFull.Fields.Update
'Zusammen setzten von Betreuernamen
If objRstSource.Fields("ABetreuerNachname") <> "" AND objRstSource.Fields("ABetreuerVorname") <> "" Then
objRstTargetFull.Fields("ABetreuerName").Value = objRstSource.Fields("ABetreuerNachname").Value & ", " & objRstSource.Fields("ABetreuerVorname").Value
End If
'ende
'geändert 3.12.04
'Zusammen setzten von Verantwortlichennamen
If objRstSource.Fields("FVerantwortlicherNachname") <> "" AND objRstSource.Fields("FVerantwortlicherVorname") <> "" Then
objRstTargetFull.Fields("FVerantwortlicherName").Value = objRstSource.Fields("FVerantwortlicherNachname").Value & ", " & objRstSource.Fields("FVerantwortlicherVorname").Value
End If
'ende
'geänert 8.12.04 Die letzte änderung der Daten wird angezeigt
If objRstSource.Fields("FDatumEdit") <> "" Then
objRstTargetFull.Fields("FEditDatum").Value = objRstSource.Fields("FDatumEdit").Value
End If
If objRstSource.Fields("ADatumEdit") <> "" Then
objRstTargetFull.Fields("AEditDatum").Value = objRstSource.Fields("ADatumEdit").Value
End If
'ende
'geändert 3.12.04
'objRstTargetFull.Fields.Update
' If objRstSource.Fields("FOrt") <> "" Then
' objRstTargetFull.Fields("urn:schemas:contacts.l").value = objRstSource.Fields("FOrt").Value
' End If
'ende
'geändert 3.12.04
' Exportieren der Postanschrif (Häkchen setzten)
objRstTargetFull.Fields.Item("urn:schemas:contacts:mailingaddressid").value = 2 'cdoBusinessAddress
'ende
'If objRstSource.Fields("AName") <> "" OR objRstSource.Fields("AVorname") <> "" Then
' objRstTargetFull.Fields("urn:schemas:contacts:fileas").Value = objRstSource.Fields("AName").Value & ", " &objRstSource.Fields("AVorname").Value
objRstTargetFull.Fields.Update
If objRstSource.Fields("AEMail") <> "" OR objRstSource.Fields("FEMail").Value <> "" Then
'WScript.echo "AditoExchange: MAPI ("&ZZZ&"). "& ZeitStart & " -> " & Time
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/fileunder").Value = objRstSource.Fields("AVorname").Value & " " & objRstSource.Fields("AName").Value
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/subject").Value = objRstSource.Fields("AVorname").Value & " " & objRstSource.Fields("AName").Value
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/fileunderid").Value = objRstSource.Fields("AID").Value '& "_" & objRstSource.Fields("FID").Value
If objRstSource.Fields("AEMail") <> "" Then
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/email1addrtype").Value = "SMTP"
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/email1originaldisplayname").Value = objRstSource.Fields("AEMail").Value
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/email1address").Value = objRstSource.Fields("AEMail").Value
End if
If objRstSource.Fields("FEMail") <> "" Then
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/email2addrtype").Value = "SMTP"
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/email2originaldisplayname").Value = objRstSource.Fields("FEMail").Value
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/email2address").Value = objRstSource.Fields("FEMail").Value
End if
objRstTargetFull.Fields("http://schemas.microsoft.com/mapi/emaillisttype").Value = 1
objRstTargetFull.Fields.Update
' objRstTargetFull.Fields("AVollständigeAnrede").Value= _
' objRstSource.Fields("AAnrede").Value & " " & _
' objRstSource.Fields("ATitel").Value & " " & _
' objRstSource.Fields("AVorname").Value & " " & _
' objRstSource.Fields("AName").Value
' End If
End If
'geändert 6.12.04 Anzeige der Speicherung in drei Schritten
If objRstSource.Fields("AName") <> "" Then
If objRstSource.Fields("AVorname") <> "" Then
'Ist Name und Vorname ungleich nix denn Speichere Name, Vorname ab
objRstTargetFull.Fields("urn:schemas:contacts:fileas").Value = objRstSource.Fields("AName").Value & ", " & objRstSource.Fields("AVorname").Value
objRstTargetFull.Fields.Item("urn:schemas:contacts:fileasid").value = 1 'cdoBusinessAddress
Else
'Ist der Name ungleich nix und der Vorname gleich nix Speichere nur den Namen
objRstTargetFull.Fields("urn:schemas:contacts:fileas").Value = objRstSource.Fields("AName").Value
objRstTargetFull.Fields.Item("urn:schemas:contacts:fileasid").value = 1
End If
Else
'Ist Name gleich nix wird der Firmname in der Speicherung eingetragen
objRstTargetFull.Fields("urn:schemas:contacts:fileas").Value = objRstSource.Fields("FName").Value
objRstTargetFull.Fields.Item("urn:schemas:contacts:fileasid").value = 3 'cdoBusinessAddress
End If
'ende
' Do some processing to make the body content with the link to CRM and TAPI
strBody = ""
strBody = _
"<!DOCTYPE HTML PUBLIC " & Chr(34) & "-//W3C//DTD HTML 3.2//EN\" & Chr(34) & ">" & _
"<HTML>" & _
"<HEAD>" & _
"<META NAME=" & Chr(34) & "Generator" & Chr(34) & " CONTENT=" & Chr(34) & "MS Exchange Server version 6.0.4417.0" & Chr(34) & ">" & _
"<TITLE></TITLE>" & _
"</HEAD>" & _
"<BODY>" & _
strBody & _
"</BODY>" & _
"</HTML>"
'Debug.Print strBody
objRstTargetFull.Fields("urn:schemas:httpmail:htmldescription").Value = ""
'WScript.Echo objRstTargetFull.Fields("F_NameLang").Value
objRstTargetFull.Fields.Update
If objRstTargetFull.State = adStateOpen Then
objRstTargetFull.Close
End If
ZZZ=ZZZ+1
objRstSource.MoveNext
if ((ZZZ+250) mod 250) = 0 then call Message(1,1,"AditoExchange","Read ("&ZZZ&")","")
if ZZZ>MaxRecords and MaxRecords <> "" Then exit do
Loop
if ZZZ>0 then call Message(1,1,"AditoExchange","ReadFinish ("&ZZZ&")","")
If objRstSource.State = adStateOpen Then
objRstSource.Close
End If
If objCnnSource.State = adStateOpen Then
objCnnSource.Close
End If
If objCnnTargetFull.State = adStateOpen Then
objCnnTargetFull.Close
End If
Set objRstSource = Nothing
Set objCnnSource = Nothing
Set objCnnTargetFull = Nothing
Set objCnnTargetPart = Nothing
End Sub
Public Sub Message(Fenster,Protokoll,Name,Stichwort,Beschreibung)
Dim Text
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
text=name&" ("&time&"): "&Stichwort&" / "&Beschreibung
if Fenster > 0 Then WScript.echo Text
if protokoll > 0 Then WshShell.LogEvent protokoll-1, Text
end sub
ZeitStart=time
call Message(0,0,"AditoExchange","Started","")
call Kontakt_Add()
if not err.Number then
call Message(0,0,"AditoExchange","Success","" )
else
call Message(0,1,"AditoExchange","Failed","")
end if
Danke schon im voraus
Antworten
Vorsicht bei der Eingabe: Die Zeichen ' oder -- sind nicht erlaubt!
