' Symantec ScriptBlocking Authenticated File
' C43327A1-334C-416C-92BA-F2922BBE07A7

'*********************************************************************************************
'
' FormelACT
'
'*********************************************************************************************
'
' Author: Robert Schellmann
' E-Mail: rs@melville-schellmann.de
' Web Page: http://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:
'           03/15/2003 - Version 1.0 This code was released
'
'*********************************************************************************************
Option Explicit

Public Const cAnwendung = "FormelACT"
Public Const cVersion = "1.0"
Public Const cMarkeFieldID = "%"
Public Const cMarkeSpace = "_"
Public Const cMarkeTargetFieldSeparator = "="

Public ACTAPP
Public ACTView

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
		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 = 1 OR ACTView.Type = 3 Then
				InitACTOLE = True
			End If
		End If
	End If
End If


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

' --------------------------------------------------------------------------
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
						On Error Resume Next
							sFieldValue = 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
						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 ExecuteFormel(sFullFormel)

Dim sFormel 
Dim sParsedFormel 
Dim sResult
Dim sTargetFieldID
Dim lPos

ExecuteFormel = False

sFullFormel = Trim(sFullFormel)
If Len(sFullFormel) = 0 Then
	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
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
sParsedFormel = ParseFormel(sFormel)
If sParsedFormel <> "" Then
	On Error Resume Next 
		sResult = 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
End If
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

End Function

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

Dim i
Dim sZeile
Dim FSO
Dim fDatei


Randomize
sZeile = ""
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 + vbCrLf + _
	       "© 2004 by Melville-Schellmann"
Else
	If InitACTOLE = True Then
		Set FSO = CreateObject("Scripting.FileSystemObject")
		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
				End If
			Loop
			fDatei.Close
		Else
			If ExecuteFormel(sZeile) = True Then
			End If
		End If
	End If
	Set ACTAPP = Nothing
	Set ACTView = Nothing
End If

End Sub