'*********************************************************************************************
'
' FormelACT
'
'*********************************************************************************************
'
' Author: Robert Schellmann
' E-Mail: rs@melville-schellmann.de
' Web Page: https://www.melville-schellmann.de
'
' Distribution: You can freely use this code in your own applications but you
'               can't publish this code in a web site, online service, or any
'               other media, without my express permission.
'
' Usage: at your own risk.
'
' History:
'           01/02/2006 - Version 1.10 Write data in email-field %200 with all contact option
'           07/20/2005 - Version 1.9  Paths with blanks are allowed with the RUN-Command
'           05/12/2005 - Version 1.8  CStr for Dates implemented
'           03/23/2005 - Version 1.7  %0 as Dummy field-id
'					RUN-Command
'           01/24/2005 - Version 1.6  ":" as comment marker, 
'				      "?" apply formula on all contacts in current ACT! lookup
'				      "$" same as "?" without confirmation
'				      IIF text corrected
'           01/17/2005 - Version 1.5  file parameter without path, example ...\FormelACT.vbs formeln.txt,
'			     	      file must be stored in the same folder as the FormelACT.vbs
'           06/22/2003 - Version 1.4  optional query dialog, registry-puffers with field-ids %9000 and higher
'           04/20/2003 - Version 1.3  check for txt-file exists
'           04/20/2003 - Version 1.2  Semicolon as command separator in IIF-Command
'           04/19/2003 - Version 1.1  IIF-Command was added
'           03/15/2003 - Version 1.0  This code was released
'
'*********************************************************************************************
Option Explicit

Public Const cMeldung = "" ' Hier den gewünschten Dialogtext eingeben
Public Const cButtons = 292 '4+256+32 
'VALUE DESCRIPTION 
'0	Show OK button 
'1 	Show OK and cancel buttons 
'2	Show abort, retry, ignore buttons 
'3	Show yes, no cancel buttons 
'4	Show yes, no buttons 
'5	Show retry, cancel buttons 
'16	Show critical message icon 
'32	Show warning query button 
'48	Show warning message icon 
'64	Show information message icon 
'0	First button is default
'256	Second button is default
'512	Third button is default 
'768	Fourth button is default
'0	Demands that the user respond to the dialog before allowing continuation of work in current application 
'4096	Causes suspension of all applications until the user responds to the dialog 

Public Const cAnwendung = "FormelACT"
Public Const cVersion = "1.10"
Public Const cMarkeFieldID = "%"
Public Const cMarkeComment = ":"
Public Const cMarkeSearch = "?"
Public Const cMarkeSearchWithoutConfirmation = "$"
Public Const cMarkeSpace = "_"
Public Const cMarkeTargetFieldSeparator = "="
Public Const cIIFSeparator = ";"
Public Const cStatusSeparator = " - "
Public Const cRegPathPuffers="HKCU\SOFTWARE\VB and VBA Program Settings\FormelACT\Puffers\"
Public Const cFieldID_NIL = 0 
Public Const cFieldID_ACTMin = 1 
Public Const cFieldID_ACTMax = 1999
Public Const cFieldID_Clipboard = 2000 		' ClipBoard function not implemented yet
Public Const cFieldID_Counter = 3000		' Recordnumber 
Public Const cFieldID_RegPuffersMin = 9000 	' Field-IDS for Registry Puffers
Public Const cFieldID_RegPuffersMax = 9099 	

Public Const ModCurrent = 1
Public Const ModSearch = 2

Public Const AVContact = 1
Public Const AVGroup = 3

Public FSO
Public ACTAPP
Public ACTView
Public ACTDatabase
Public ACTTable
Public ScriptFolderName
Public Modus
Public CurrentIDs
Public CurrentRecordNumber

Public WSH

Main

' --------------------------------------------------------------------------
Function InitACTOLE()

InitACTOLE = False

On Error Resume Next
	Set ACTAPP = CreateObject("ACTOLE.APPOBJECT")
	If Err.Number <> 0 Then
		MsgBox "Es konnte keine OLE-Verbindung zur ACT!-Anwendung erstellt werden." + vbCrLf + _
		       "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
		       "Fehlerbeschreibung: " + Err.Description, vbExlcamation , cAnwendung
		On Error GoTo 0
		Exit Function
	End If
On Error GoTo 0

If Not ACTAPP Is Nothing Then
	If ACTAPP.GetOpenDBName() <> "" then
		Set ACTView = ACTAPP.Views.GetActive
		If Not ACTView Is Nothing Then
			If ACTView.Type = AVContact OR ACTView.Type = AVGroup Then
				InitACTOLE = True
			End If
		End If
	End If
End If

End Function
' --------------------------------------------------------------------------
Function InitACTDataBase()

InitACTDataBase = False

'On Error Resume Next
PrintStatus "Verbindung zur ACT!-Datenbank wird aufgebaut..."
Set ACTDatabase = CreateObject("ACTOLE.Database")
Select Case Err.Number
	Case 429, 501
		MsgBox "Error "+ CStr(Err.Number)+ " ACTOLE" + vbCrLf + _
		               cAnwendung + " kann keine OLE-Verbindung zur ACT!-Datenbank erstellen." + vbCrLf + _
		               "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
		               "Fehlerbeschreibung: " + Err.Description , vbExlcamation , cAnwendung
		PrintStatus ""
		Exit Function
	Case 0
		ACTDatabase.OpenEx ""
		PrintStatus "Verbindung zur ACT!-Datenbank wurde aufgebaut."
	Case Else
		MsgBox "Error " + CStr(Err.Number) + " ACTOLE" + vbCrLf + _
                  	cAnwendung + " kann keine OLE-Verbindung zur ACT!-Datenbank erstellen." + vbCrLf + _
			"Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
			"Fehlerbeschreibung: " + Err.Description , vbExlcamation , cAnwendung	
		PrintStatus ""
		Exit Function
End Select
'On Error Goto 0

InitACTDataBase = True

End Function
' --------------------------------------------------------------------------
Function SetCurrentLookup()

Dim sTempFile

SetCurrentLookup = False

If ACTAPP Is Nothing Then Exit Function
If ACTDatabase Is Nothing Then Exit Function
If FSO is Nothing Then Exit Function


PrintStatus "Die aktuelle ACT!-Suche wird ermittelt..."
Select Case ACTView.Type
	Case AVContact
		Set ACTTable = ACTDatabase.Contact
		' Save Current COntact-Lookup
		sTempFile = FSO.GetSpecialFolder(2) + "\" + cAnwendung + "_" + FSO.GetTempName
		ACTAPP.SaveCurrentLookup sTempFile
		Select Case ACTAPP.GetLastError
			Case 0   'S_OK 
			Case Else
				MsgBox "Es ist ein OLE-Fehler beim Speichern der aktuellen ACT!-Suche aufgetreten." + vbCrLf + _
				       "OLE-Fehlernummer: " + CStr(ACTAPP.GetLastError) + vbCrLf + _
				       "Temporäre Lookup-Datei:" + sTempFile , vbExclamation , cAnwendung
				Exit Function
		End Select
		If FSO.FileExists(sTempFile) = False Then
			MsgBox "Die temporäre Lookup-Datei '" + sTempFile + "' konnte nicht gefunden werden.", vbExclamation , cAnwendung
			Exit Function
		End If
		' Load Current Contact Lookup
		ACTTable.LoadLookUpQuery sTempFile
		Select Case ACTTable.LastError
			Case 0   'S_OK 
			Case Else
				MsgBox "Es ist ein OLE-Fehler beim Laden der aktuellen ACT!-Suche aufgetreten." + vbCrLf + _
				       "OLE-Fehlernummer: " + CStr(ACTTable.LastError) + vbCrLf + _
				       "Datei:" + sTempFile , vbExclamation , cAnwendung
				Exit Function
		End Select
		FSO.DeleteFile sTempFile

	Case AVGroup
		Set ACTTable = ACTDatabase.Group
End Select
PrintStatus "Die aktuelle ACT!-Suche wird ermittelt...."
ACTTable.MoveFirst

PrintStatus ""

SetCurrentLookup = True

End Function
' --------------------------------------------------------------------------
Sub PrintError(sText, sFormel, lPos)

If sFormel = "" Then
		MsgBox sText, vbExclamation, cAnwendung
Else
	If lPos= 0 Then
		MsgBox sText + vbCrLf+ _
					"Formel: " + sFormel, _
					vbExclamation, cAnwendung
	Else	
		MsgBox sText + vbCrLf+ _
					"Formel: " + Left(sFormel,lPos) + "<-Fehler!" + Right(sFormel,Len(sFormel)-lPos), _
					vbExclamation, cAnwendung
	End If
End If
End Sub
' --------------------------------------------------------------------------
Sub PrintStatus (sText)
	If Not ACTAPP Is Nothing Then
		If sText = "" Then
			ACTAPP.Caption = Left(ACTAPP.Caption+cStatusSeparator,InStr(ACTAPP.Caption+cStatusSeparator,cStatusSeparator)-1)
		Else
			ACTAPP.Caption = Left(ACTAPP.Caption+cStatusSeparator,InStr(ACTAPP.Caption+cStatusSeparator,cStatusSeparator)-1)+cStatusSeparator+cAnwendung+": "+sText + " "
		End If
	End If
End Sub
' --------------------------------------------------------------------------
Function ParseFormel(ByVal sFormel) 

Dim sParsedFormel
Dim sCurrent
Dim sLast
Dim lPos
Dim lAnzahlZeichen
Dim bIsCommand
Dim sFielDID
Dim sFieldValue 

Dim lAsc0 
Dim lAsc9

lAsc0 = Asc("0")
lAsc9 = Asc("9")

ParseFormel = ""
sParsedFormel = ""
sLast = ""
bIsCommand = False
sFormel = sFormel + " "
lAnzahlZeichen = Len(sFormel)
For lPos = 1 To lAnzahlZeichen
	sCurrent = Mid(sFormel,lPos,1)
	If bIsCommand = True Then
		If Asc(sCurrent) >= lAsc0 And Asc(sCurrent) <= lAsc9 Then
			sFielDID = sFielDID + sCurrent
		Else
			Select Case sCurrent
				Case cMarkeSpace,cMarkeFieldID
					sParsedFormel = sParsedFormel + sCurrent
					bIsCommand = False
				Case Else
					If Len(sFielDID) = 0 Then
						PrintError "Eine FeldID wurde nicht in der Formel angegeben.",sFormel,lPos
						ParseFormel = ""
						Exit Function
					Else
						If CLng(sFielDID) >= cFieldID_ACTMin And CLng(sFielDID) <= cFieldID_ACTMax Then
							Select Case Modus
								Case ModCurrent
									On Error Resume Next
										sFieldValue = CStr(ACTView.GetField(CLng(sFielDID)))
										If Err.Number <> 0 Then
											PrintError "Es konnte nicht der ACT!-Feldwert für das Feld mit der ID """ + sFielDID + """ bestimmt werden." + vbCrLf + _
											           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
											           "Fehlerbeschreibung: "+ CStr(Err.Description), sFormel, 0
											On Error GoTo 0
											ParseFormel = ""
											Exit Function
										End If
									On Error GoTo 0
									Select Case ACTView.GetLastError
										Case 0   'S_OK 
										Case 163 'S_INVALID_ID
											PrintError "Die FeldID in der Formel existiert nicht in der ACT!-Datenbank.",sFormel,lPos
											ParseFormel = ""
											Exit Function
										Case Else
											PrintError "Es ist ein OLE-Fehler beim Zugriff auf das ACT!-Feld mit der ID """ + sFielDID + """ aufgetreten." + vbCrLf + _
											           "OLE-Fehlernummer: " + CStr(ACTView.GetLastError), sFormel, 0
											ParseFormel = ""
											Exit Function
									End Select
								Case ModSearch
									On Error Resume Next
										sFieldValue = CStr(ACTTable.Data(CLng(sFielDID)))
										If Err.Number <> 0 Then
											PrintError "Es konnte nicht der ACT!-Feldwert für das Feld mit der ID """ + sFielDID + """ bestimmt werden." + vbCrLf + _
											           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
											           "Fehlerbeschreibung: "+ CStr(Err.Description), sFormel, 0
											On Error GoTo 0
											ParseFormel = ""
											Exit Function
										End If
									On Error GoTo 0
									Select Case ACTTable.LastError
										Case 0   'S_OK 
										Case -98 'Status_InvalidField
											PrintError "Die FeldID in der Formel existiert nicht in der ACT!-Datenbank.",sFormel,lPos
											ParseFormel = ""
											Exit Function
										Case Else
											PrintError "Es ist ein OLE-Fehler beim Zugriff auf das ACT!-Feld mit der ID """ + sFielDID + """ aufgetreten." + vbCrLf + _
											           "OLE-Fehlernummer: " + CStr(ACTTable.LastError), sFormel, 0
											ParseFormel = ""
											Exit Function
									End Select
								Case Else
							End Select
						Else If CLng(sFielDID) >= cFieldID_RegPuffersMin And CLng(sFielDID) <= cFieldID_RegPuffersMax Then
							sFieldValue = CStr(WSH.RegRead (cRegPathPuffers & Trim(sFielDID)))
						Else If CLng(sFielDID) = cFieldID_Clipboard Then
							' ClipBoard function not implemented yet
						Else If CLng(sFielDID) = cFieldID_Counter Then
							sFieldValue = CStr(CurrentRecordNumber)
						End If
						End If
						End If
						End If
						sParsedFormel = sParsedFormel + sFieldValue + sCurrent
						bIsCommand = False
					End If
			End Select
		End If
	Else
		Select Case sCurrent
			Case cMarkeSpace
				sParsedFormel = sParsedFormel + " "
			Case cMarkeFieldID
				sFielDID = ""
				bIsCommand = True
			Case Else
				sParsedFormel = sParsedFormel + sCurrent
		End Select
	End If
Next 

ParseFormel = sParsedFormel
End Function

' --------------------------------------------------------------------------
Function ParseIIF(ByVal sFormel, ByRef sBedingung, ByRef sAusdruckWahr, ByRef sAusdruckFalsch)
Dim lPos
Dim lAnzahlZeichen
Dim sCurrentZeichen
Dim sCurrentAusdruck
Dim lCountAusdruck
Dim bText

ParseIIF = False
lAnzahlZeichen = Len(sFormel)
bText = False
lCountAusdruck = 1
sBedingung = ""
sAusdruckWahr = ""
sAusdruckFalsch = ""
sCurrentAusdruck = ""
For lPos = 1 To lAnzahlZeichen
	sCurrentZeichen = Mid(sFormel, LPos, 1)
	If bText = False Then
		If sCurrentZeichen = cIIFSeparator Then
			Select Case lCountAusdruck
				Case 1 ' Bedingung
					sBedingung = Trim(sCurrentAusdruck)
				Case 2 ' AusdruckWahr
					sAusdruckWahr = Trim(sCurrentAusdruck)
				Case 3 ' AusdruckFalsch
					sAusdruckFalsch = Trim(sCurrentAusdruck)
				Case Else
					Exit For
			End Select
			lCountAusdruck = lCountAusdruck + 1
			sCurrentAusdruck = ""
		Else
			If sCurrentZeichen = """" Then
				bText = True
			End If
			sCurrentAusdruck = sCurrentAusdruck + sCurrentZeichen
		End If
	Else
		If sCurrentZeichen = """" Then
			bText = False
		End If
		sCurrentAusdruck = sCurrentAusdruck + sCurrentZeichen
	End If
Next
If lCountAusdruck < 3 Then 
	PrintError "Es fehlt ein Parameter in der IIF-Anweisung." + vbCrLf + _
		   "Format: IIF(<Bedingung>;<Ausdruck-Wahr>;<Ausdruck-Falsch>)" + VbCrLf + _
		   "Ausdruck: IIF(" + sFormel+")","", 0
	Exit Function
End If
If sBedingung = "" Then
	PrintError "Es fehlt die Bedingung in der IIF-Anweisung." + vbCrLf + _
		   "Format: IIF(<Bedingung>;<Ausdruck-Wahr>;<Ausdruck-Falsch>)" + VbCrLf + _
		   "Ausdruck: IIF(" + sFormel+")","", 0
	Exit Function
End If
If lCountAusdruck = 3 Then
	sAusdruckFalsch = sCurrentAusdruck
End If
ParseIIF = True

End Function
' --------------------------------------------------------------------------
Function ExecuteFormel(sFullFormel)

Dim sFormel 
Dim sParsedFormel 
Dim sResult
Dim bResult
Dim sTargetFieldID
Dim lPos
Dim sIIFBedingung
Dim sIIFAusdruckWahr
Dim sIIFAusdruckFalsch

Dim sRUNAusdruck
Dim lRecordCount
Dim sQuestion

Dim ACTEmail
Dim lEmailCount
Dim sContactUniqueID
Dim i

ExecuteFormel = False

sFullFormel = Trim(sFullFormel)
If Len(sFullFormel) = 0 Then
	Exit Function
End If
If Left(sFullFormel,1) = cMarkeComment Then
	' ignore comment
	Exit Function
End If
If Len(sFullFormel) < 4 Then
	PrintError "Es ist ein Fehler in der Formel. Sie ist zu kurz.",sFullFormel,0
	Exit Function
End If
Select Case Left(sFullFormel,1)
	Case cMarkeFieldID
		Modus = ModCurrent
		lRecordCount = 1
	Case cMarkeSearch , cMarkeSearchWithoutConfirmation
		If Left(sFullFormel,1) = cMarkeSearch Then
			sQuestion = "Sind Sie sicher, dass die folgende Formel:"+ vbCrLf + vbCrLf + _
				    Right(sFullFormel , Len(sFullFormel)-1) + vbCrLf + vbCrLf
			Select Case ACTView.Type 				  
				Case AVContact
					sQuestion = sQuestion + "auf alle ACT!-Kontakte in der aktuellen ACT!-Suche angewandt werden soll?" + vbCrLf
				Case AVGroup
					sQuestion = sQuestion + "auf alle ACT!-Gruppen angewandt werden soll?" + vbCrLf
			End Select
			sQuestion = sQuestion + vbCrLf + "Diese Änderungen können nicht rückgängig gemacht werden."
			If MsgBox(sQuestion, vbQuestion + vbYesNo, cAnwendung) = vbNo Then
				ExecuteFormel = True
				Exit Function
			End If
		End If
		Modus = ModSearch
		If ACTDatabase Is Nothing Then
			If InitACTDataBase = False Then 
				Exit Function
			End If
		End If
		If SetCurrentLookup = False Then
			Exit Function
		End If
		lRecordCount = ACTTable.RecordCount
		sFullFormel = Right(sFullFormel , Len(sFullFormel)-1)
	Case Else
		PrintError "Es ist ein Fehler in der Formel. Es muss zuerst ein Zielfeld angegeben werden.",sFullFormel,0
		Exit Function
End Select	

If Left(sFullFormel,1) <> cMarkeFieldID Then
	PrintError "Es ist ein Fehler in der Formel. Es muss zuerst ein Zielfeld angegeben werden.",sFullFormel,0
	Exit Function
End If
lPos = InStr(sFullFormel,cMarkeTargetFieldSeparator)
If lPos < 3 Then
	PrintError "Es ist ein Fehler in der Formel. Nach dem Zielfeld muss ein """+ cMarkeTargetFieldSeparator +"""-Zeichen kommen.",sFullFormel,0
	Exit Function
End If
sTargetFieldID = Mid(sFullFormel, 2, lPos-2)
If IsNumeric(sTargetFieldID) = False Then
	PrintError "Es ist ein Fehler in der Formel. Die ID """+ sTargetFieldID + """ des Zielfeldes ist keine Zahl.",sFullFormel,0
	Exit Function
End If
sFormel = Trim(Right(sFullFormel, Len(sFullFormel)-lPos))
If sFormel = "" Then
	PrintError "Es fehlt die Formel nach dem Zielfeld.",sFullFormel,0
	Exit Function
End If

For CurrentRecordNumber = 1 to lRecordCount

	sParsedFormel = Trim(ParseFormel(sFormel))
	
	If sParsedFormel <> "" Then
		If InStr(LCase(sParsedFormel),"iif(") = 1 And Right(sParsedFormel,1)=")" Then
			' ************* IIF-Command *************
			If ParseIIF(Mid(sParsedFormel, 5, Len(sParsedFormel) - 5), sIIFBedingung, sIIFAusdruckWahr, sIIFAusdruckFalsch) = True Then
				On Error Resume Next 
					bResult = Eval(sIIFBedingung)
					If Err.Number <> 0 Then
						PrintError "Es ist ein Fehler beim Verarbeiten der IIF-Bedingung aufgetreten." + vbCrLf + _
						           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
								       "Fehlerbeschreibung: " + Err.Description + vbCrLf + _
								       "Original Formel: " + sFormel + vbCrLf + _
								       "Gefüllte Formel: " + sParsedFormel + vbcrlf, "", 0
						On Error GoTo 0
						Exit Function
					End If
				On Error GoTo 0
				If bResult = True Then
					If sIIFAusdruckWahr <> "" Then
						On Error Resume Next 
							sResult = Eval(sIIFAusdruckWahr)
							If Err.Number <> 0 Then
								PrintError "Es ist ein Fehler beim Erstellen des Ergebnisses aus dem Wahr-Teil der IIF-Anweisung aufgetreten." + vbCrLf + _
								           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
										       "Fehlerbeschreibung: " + Err.Description + vbCrLf + _
										       "Original Formel: " + sFormel + vbCrLf + _
										       "Gefüllte Formel: " + sParsedFormel + vbcrlf, "", 0
								On Error GoTo 0
								Exit Function
							End If
						On Error GoTo 0
					Else
						Exit Function
					End If
				Else
					
					If sIIFAusdruckFalsch <> "" Then
						On Error Resume Next 
							sResult = Eval(sIIFAusdruckFalsch)
							If Err.Number <> 0 Then
								PrintError "Es ist ein Fehler beim Erstellen des Ergebnisses aus dem Falsch-Teil der IIF-Anweisung aufgetreten." + vbCrLf + _
								           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
										       "Fehlerbeschreibung: " + Err.Description + vbCrLf + _
										       "Original Formel: " + sFormel + vbCrLf + _
										       "Gefüllte Formel: " + sParsedFormel + vbcrlf, "", 0
								On Error GoTo 0
								Exit Function
							End If
						On Error GoTo 0
					Else
						Exit Function
					End If
				End If
			End If
		Else	
		
			If InStr(LCase(sParsedFormel),"run(") = 1 And Right(sParsedFormel,1)=")" Then
				' ************* RUN-Command *************
				sRUNAusdruck = Mid(sParsedFormel, 5, Len(sParsedFormel) - 5)
				On Error Resume Next
					sRUNAusdruck = Trim(CStr(Eval(sRUNAusdruck)))
					If Err.Number <> 0 And Err.number <> -2147024894 Then
						PrintError "Es ist ein Fehler beim Erstellen des RUN-Audrucks aufgetreten." + vbCrLf + _
						           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
							   "Fehlerbeschreibung: " + Err.Description + vbCrLf + _
							   "Original Formel: " + sFormel + vbCrLf + _
							   "Gefüllte Formel: " + sParsedFormel + vbcrlf, "", 0
						On Error GoTo 0
						Exit Function
					End If
				On Error GoTo 0
				If sRUNAusdruck <> "" Then
					If FSO.FileExists(sRUNAusdruck)=True Then
						If Left(sRUNAusdruck,1)<>"""" Then
							sRUNAusdruck="""" + sRUNAusdruck + """"
						End If
					End If
					On Error Resume Next
						sResult = WSH.Run(sRUNAusdruck,1,False)
						Select Case Err.Number 
							Case 0
							Case Else
								PrintError "Es ist ein Fehler beim Erstellen des RUN-Audrucks aufgetreten." + vbCrLf + _
								           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
									   "Fehlerbeschreibung: " + Err.Description + vbCrLf + _
									   "Original Formel: " + sFormel + vbCrLf + _
									   "Gefüllte Formel: " + sParsedFormel + vbcrlf, "", 0
								On Error GoTo 0
								Exit Function
						End Select
					On Error GoTo 0	
				End If
			Else
				' ************* Standard formel *************
				On Error Resume Next 
					sResult = CStr(Eval(sParsedFormel))
					If Err.Number <> 0 Then
						PrintError "Es ist ein Fehler beim Erstellen des Ergebnisses aufgetreten." + vbCrLf + _
						           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
								       "Fehlerbeschreibung: " + Err.Description + vbCrLf + _
								       "Original Formel: " + sFormel + vbCrLf + _
								       "Gefüllte Formel: " + sParsedFormel + vbcrlf, "", 0
						On Error GoTo 0
						Exit Function
					End If
				On Error GoTo 0
			End If
		End If
	End If
	If CLng(sTargetFieldID) > 0 And CLng(sTargetFieldID) < 2000 Then
		Select Case Modus
			Case ModCurrent
				On Error Resume Next
					ACTView.SetField CLng(sTargetFieldID), sResult
					If Err.Number <> 0 Then
						PrintError "Es konnte nicht das Ergebnis """ + sResult + """ in das ACT!-Feld mit der ID """ + sTargetFieldID + """ geschrieben werden." + vbCrLf + _
						           "Fehlernummer: " + CStr(Err.Number) + vbCrLf + _
						           "Fehlerbeschreibung: "+ CStr(Err.Description), "", 0
						On Error GoTo 0
						Exit Function
					End If
				On Error GoTo 0
				Select Case ACTView.GetLastError
					Case 0   'S_OK 
						ExecuteFormel = True
					Case 117,163 'S_INVALID_INPUT,S_INVALID_ID
						PrintError "Die FeldID "+ sTargetFieldID +" für das Zielfeld existiert nicht in der ACT!-Datenbank.",sFullFormel,0
						Exit Function
					Case Else
						PrintError "Es ist ein OLE-Fehler beim Zugriff auf das ACT!-Zielfeld mit der ID """ + sTargetFieldID + """ aufgetreten." + vbCrLf + _
						           "OLE-Fehlernummer: " + CStr(ACTView.GetLastError), "", 0
						Exit Function
				End Select
			Case ModSearch
				'MsgBox CStr(CurrentRecordNumber) + "/" + CStr(lRecordCount) + ":" + sTargetFieldID + "=" + CStr(sResult)
				On Error GoTo 0
				If sTargetFieldID="200" Then
					If sResult<>"" Then
						Set ACTEmail = ACTDatabase.Email
						sContactUniqueID = CStr(ACTTable.Data(CLng(1)))
						ACTEmail.setcontactscope sContactUniqueID
						lEmailCount = ACTEmail.RecordCount
						Select Case lEmailCount
							Case 0
								ACTEmail.Add
								ACTEmail.Data 28,sContactUniqueID
								ACTEmail.Data 25,sResult
								ACTEmail.Data 27,1
								ACTEmail.Update
								Select Case ACTEmail.LastError 
									Case 0
									Case -500
										PrintError "Es konnten die Email-Daten nicht in das ACT!-Feld mit der ID """ + sTargetFieldID + """ gespeichert werden." + vbCrLf + _
											   "Der Datensatz mit der lfd. Nummer " + CStr(CurrentRecordNumber) + " ist gesperrt.", sFormel, 0
									Case Else
										PrintError "Es ist ein OLE-Fehler beim Speichern in das ACT!-Emailfeld mit der ID """ + sTargetFieldID + """ aufgetreten." + vbCrLf + _
										           "OLE-Fehlernummer: " + CStr(ACTEmail.LastError), sFormel, 0
										Exit Function					
								End Select
							Case Else
								ACTEmail.MoveFirst
								For i = 1 To lEmailCount
									If CStr(ACTEmail.Data(27)) = "1" Then
										ACTEmail.Edit
										ACTEmail.Data 28,sContactUniqueID
										ACTEmail.Data 25,sResult
										ACTEmail.Data 27,1
										ACTEmail.Update
										Select Case ACTEmail.LastError 
											Case 0
											Case -500
												PrintError "Es konnten die Email-Daten nicht in das ACT!-Feld mit der ID """ + sTargetFieldID + """ gespeichert werden." + vbCrLf + _
													   "Der Datensatz mit der lfd. Nummer " + CStr(CurrentRecordNumber) + " ist gesperrt.", sFormel, 0
											Case Else
												PrintError "Es ist ein OLE-Fehler beim Speichern in das ACT!-Emailfeld mit der ID """ + sTargetFieldID + """ aufgetreten." + vbCrLf + _
												           "OLE-Fehlernummer: " + CStr(ACTEmail.LastError), sFormel, 0
												Exit Function					
										End Select
									End If
									ACTEMail.MoveNext
								Next 						
						End Select
					End If
				Else
					
					ACTTable.Edit
					Select Case ACTTable.LastError 
						Case 0
						Case -500
							PrintError "Es konnten die Daten nicht in das ACT!-Feld mit der ID """ + sTargetFieldID + """ gespeichert werden." + vbCrLf + _
								   "Der Datensatz mit der lfd. Nummer " + CStr(CurrentRecordNumber) + " ist gesperrt.", sFormel, 0
						Case Else
							PrintError "Es ist ein OLE-Fehler beim Speichern in das ACT!-Feld mit der ID """ + sTargetFieldID + """ aufgetreten." + vbCrLf + _
							           "OLE-Fehlernummer: " + CStr(ACTTable.LastError), sFormel, 0
							Exit Function					
					End Select
					ACTTable.Data CLng(sTargetFieldID), sResult
					Select Case ACTTable.LastError 
						Case 0
						Case -98 'Status_InvalidField
							PrintError "Die FeldID "+ sTargetFieldID +" für das Zielfeld existiert nicht in der ACT!-Datenbank.",sFullFormel,0
							Exit Function
						Case Else
							PrintError "Es ist ein OLE-Fehler beim Speichern in das ACT!-Feld mit der ID """ + sTargetFieldID + """ aufgetreten." + vbCrLf + _
							           "OLE-Fehlernummer: " + CStr(ACTTable.LastError), sFormel, 0
							Exit Function					
					End Select
					ACTTable.Update
					Select Case ACTTable.LastError 
						Case 0
						Case Else
							PrintError "Es ist ein OLE-Fehler beim Speichern in das ACT!-Feld mit der ID """ + sTargetFieldID + """ aufgetreten." + vbCrLf + _
							           "OLE-Fehlernummer: " + CStr(ACTTable.LastError), sFormel, 0
							Exit Function					
					End Select
				End If
				ACTTable.MoveNext
				PrintStatus "Im Datensatz " + CStr(CurrentRecordNumber) + " von " + CStr(lRecordCount) + " wurde im Feld mit der ID " + sTargetFieldID + " der Wert geändert..."
			Case ModAll
		End Select
	Else If CLng(sTargetFieldID) >= 9000 Then
		WSH.RegWrite cRegPathPuffers & Trim(sTargetFieldID), sResult, "REG_SZ"
	Else If	CLng(sTargetFieldID) = 300 Then
		' ClipBoard function not implemented yet
	End If
	End If
	End If
Next

End Function

' --------------------------------------------------------------------------
Sub Main()

Dim i
Dim sZeile
Dim fDatei


Randomize
sZeile = ""

Set ACTAPP = Nothing
Set ACTView = Nothing
Set ACTDatabase = Nothing

If cMeldung <> "" Then
	If MsgBox(cMeldung, cButtons ) = vbNo Then
		Exit Sub
	End If
End If
For i = 0 To WScript.Arguments.Count - 1
	sZeile = sZeile + " " + WScript.Arguments(i)
Next
sZeile = Trim(sZeile)
If sZeile = "" Then
	MsgBox cAnwendung + " Version " + cVersion + vbCrLf + vbCrLf + _
	       "Beispiele für mögliche Aufrufe von " + cAnwendung + ":" + vbCrLf + vbCrLf + _
	       "FormelACT.vbs %52=""%51""+""_-_""+""%50""" + vbCrLf + _
	       "Verkettet den Inhalt von Benutzerfeld 2 (%51) und Benutzerfeld 1 (%50) mit dem Text "" - "" in der Mitte." + vbCrLf + _
	       "Der zusammengebaute Text wird in das Benutzerfeld 3 (%52) geschrieben." + vbCrLf + vbCrLf + _
	       "FormelACT.vbs %52=.25*%51" + vbCrLf + _
	       "In das Benutzerfeld 3(%52) wird das Produkt aus 0,25 und dem Wert im Benutzerfeld 2 (%51) geschrieben."+ vbCrLf + vbCrLf + _
	       "FormelACT.vbs C:\Test\ACTFormeln.txt"+ vbCrLf + _
	       "Aus der Textdatei ACTFormeln.txt werden die zu verarbeitenden Formeln ausgelesen." + vbCrLf + _
	       "Wenn die Textdatei im selben Ordner gespeichert ist wie die Datei FormelACT.vbs, dann"+ vbCrLf + _
	       "reicht auch der Aufruf: FormelACT.vbs ACTFormeln.txt" + vbCrLf + vbCrLf + _
	       "© 2004-2005 by Melville-Schellmann", vbInformation , cAnwendung
Else
	If InitACTOLE = True Then
		Set FSO = CreateObject("Scripting.FileSystemObject")
		Set WSH = CreateObject("WScript.Shell")
		ScriptFolderName= Left(WScript.ScriptFullName,Len(WScript.ScriptFullName)-Len(WScript.ScriptName))
		If Left(sZeile,1) = cMarkeFieldID Then
			sZeile = Replace(sZeile,"'","""")
			If ExecuteFormel(sZeile) = True Then
			End If
		Else			
			If FSO.FileExists(sZeile) = True Then
				Set fDatei = FSO.OpenTextFile(sZeile,1,False,0)
				Do While fDatei.AtEndOfStream <> True
					sZeile = fDatei.ReadLine
					If ExecuteFormel(sZeile) = True Then
						' No OPs
					End If
				Loop
				fDatei.Close
			Else
				If FSO.FileExists(ScriptFolderName+sZeile) = True Then
					Set fDatei = FSO.OpenTextFile(ScriptFolderName+sZeile,1,False,0)
					Do While fDatei.AtEndOfStream <> True
						sZeile = fDatei.ReadLine
						If ExecuteFormel(sZeile) = True Then
						End If
					Loop
					fDatei.Close
				Else
					PrintError "Es konnte nicht die Datei """ + sZeile + """ gefunden werden.","",0	
				End If
			End If
		End If
		PrintStatus ""
	Else
		PrintError "Es konnte keine Verbindung zur ACT!-Anwendung hergestellt werden.","",0
	End If
	Set ACTView = Nothing
	Set ACTAPP = Nothing
	Set ACTTable = Nothing
	Set ACTDatabase = Nothing
	Set FSO = Nothing
End If

End Sub