VERSION 5.00
Begin VB.Form frmSESIMDDE
Caption = "SESIM_DDE"
ClientHeight = 1335
ClientLeft = 60
ClientTop = 345
ClientWidth = 3885
LinkMode = 1 'Source
LinkTopic = "SESIM_DDE"
ScaleHeight = 1335
ScaleWidth = 3885
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtDDE_out
Height = 375
Left = 240
LinkTopic = "excel|temp"
TabIndex = 1
Text = "txtDDE_out"
Top = 720
Width = 3375
End
Begin VB.TextBox txtDDE_in
Height = 375
Left = 240
LinkItem = "txtDDE_in"
TabIndex = 0
Text = "txtDDE_in"
Top = 240
Width = 3375
End
End
Attribute VB_Name = "frmSESIMDDE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'********************************************************************
'*** This module contains code to handle the communication with the
'*** Excel RePorTGENerator. The communication uses the DDE technique.
'*** The frmSESIMDDE form recieves commands from RPTGEN to the
'*** txtDDE_in textbox, processes the commands and weites the result
'*** back to the RPTGEN through the txtDDE_out textbox .
'***
'*** The syntax of the incoming command string is separated using the
'*** "¤" sign as follows (positions 1 - 4 are required):
'***
'*** 1. Analysis variable
'*** 2. Excel result destination (format r1c1)
'*** 3. Statistic
'*** 4. Year of analysis
'*** 5. Selection variable
'*** 6. Selection operator
'*** 7. Selection value
'***
'*** NOTE1: No extensive error checking of the DDE command strings is done
'*** here since it is assumed to be done in RPTGEN.
'*** NOTE2: The module uses methods within frmGlobalSelection to handle the
'*** conditions set on the analyses.
Option Explicit
Option Base 1
'*** Temporary selection vectors
Dim tempselect_i() As Long, tempselect_h() As Long
'*** Old contents of txtDDE_in - to prevent multiple calculations of the same statistic
Dim oldtxt As String
'***********************************************************************
'*** Sub txtDDE_in_Change() is launched when Excel sends a command to
'*** SESIM.
'***********************************************************************
Private Sub txtDDE_in_Change()
Dim commandstring(1 To 7) As String
Dim analysis_var As String, statistic As String, year As String
Dim operator As String, selection_var As String, value As String
Dim sheet As String, cell As String, destination As String
Dim result As Double
Dim retcode As Byte
Dim i As Integer
'*** The DDE link launces multiple calls (why is this? CHECK UP!)
If txtDDE_in.text = oldtxt Then Exit Sub
'*** Initialize SESIM if it is not already done
If init_done = 0 Then Call Initsesim
'*** Load frmGlobalSelection if not already loaded
If controlcenter.CmdGlobalSelection.enabled = True Then _
controlcenter.CmdGlobalSelection_Click
'*** Check what type of command has been sent
Call check_DDEcommandtype(txtDDE_in, commandstring, retcode)
'*** Set commandstring arguments
analysis_var = commandstring(1)
destination = commandstring(2)
statistic = commandstring(3)
year = commandstring(4)
selection_var = commandstring(5)
operator = commandstring(6)
value = commandstring(7)
'*** Handle the various types of commands
Select Case retcode
'*** Global condition
Case 1
Call set_global_condition(selection_var, operator, value)
'*** Analysis with no conditions
Case 2
result = calculate_statistic(analysis_var, statistic)
'*** Send to Excel
Call send2excel(destination, CStr(result))
'*** Analysis with conditions on the analysis variable
Case 3
'*** Temporary storage of selection vectors
tempselect_i = select_i
tempselect_h = select_h
Call set_global_condition(analysis_var, operator, value)
result = calculate_statistic(analysis_var, statistic)
'*** Now delete the last selection item that was added above
nSelItems = nSelItems - 1
ReDim Preserve SelLst(maxi(1, nSelItems))
'*** Reset the selection vectors to their previous state
select_i = tempselect_i
select_h = tempselect_h
'*** Redraw the frmGlobalSelection grid
frmGlobalSelection.RedrawGrid
'*** Send to Excel
Call send2excel(destination, CStr(result))
'*** Analysis with conditions on the selection variable
Case 4
'*** Temporary storage of selection vectors
tempselect_i = select_i
tempselect_h = select_h
Call set_global_condition(selection_var, operator, value)
result = calculate_statistic(analysis_var, statistic)
'*** Now delete the last selection item that was added above
nSelItems = nSelItems - 1
ReDim Preserve SelLst(maxi(1, nSelItems))
'*** Reset the selection vectors to their previous state
select_i = tempselect_i
select_h = tempselect_h
'*** Redraw the frmGlobalSelection grid
frmGlobalSelection.RedrawGrid
'*** Send to Excel
Call send2excel(destination, CStr(result))
'*** Clear all conditions
Case 5
Call delete_selection
'*** Change year
Case 6
Call step_to_year(year)
'*** Unknown command: ERROR
Case Else
status "DDE ERROR: Unknown command: " & txtDDE_in
End Select
'*** Store text to see if it really changes
oldtxt = txtDDE_in.text
End Sub
'************************************************************************
'*** Sub set_global_condition() uses the frmGlobalSelection form to set
'*** the selection indicated by variable, operator and value.
'************************************************************************
Private Sub set_global_condition(variable As String, operator As String, _
value As String)
frmGlobalSelection.CboVar = variable
frmGlobalSelection.CboOp = operator
frmGlobalSelection.TxtVal = value
frmGlobalSelection.CmdSubmit_Click
End Sub
'************************************************************************
'*** Sub delete_selection clears elements from the global selection
'*** list if the elements has the specified variable name, operator and
'*** value specified by the arguments. If no arguments are supplied the
'*** entire list is cleared.
'************************************************************************
Public Sub delete_selection(Optional variable As String, Optional operator As String, _
Optional value As String)
'*** No arguments - clear all list
If variable = "" And operator = "" And value = "" Then
nSelItems = 0
ReDim SelLst(1)
frmGlobalSelection.Text1 = Rnd '*** Tell frmglobalSelection to update...
'*** Clear only elements given by arguments
Else
If nSelItems > 0 Then
Dim i As Integer, newcount As Integer
Dim found_match As Boolean
Dim templist() As SelItem
ReDim templist(nSelItems)
'*** Load all elements not to be deleted to temporary list
newcount = 1
found_match = False
For i = 1 To nSelItems
If SelLst(i).op = operator And SelLst(i).var = variable And _
SelLst(i).val = value Then
found_match = True
Else
templist(newcount).op = SelLst(i).op
templist(newcount).var = SelLst(i).var
templist(newcount).val = SelLst(i).val
newcount = newcount + 1
End If
Next
'*** If match found then rewrite the SelLst list
If found_match = True Then
For i = 1 To newcount - 1
SelLst(i) = templist(i)
Next
ReDim Preserve SelLst(1 To newcount - 1)
nSelItems = newcount - 1
frmGlobalSelection.Text1 = Rnd '*** Tell frmglobalSelection to update...
End If
Else
MsgBox "ERROR: trying to delete empy selection list"
End If
End If
End Sub
'**************************************************************************
'*** Sub check_DDEcommandtype() checks the type of DDE command that is
'*** contained in command. It returns the separated command parameters and
'*** the return code indicating the type of command.
'*** Arguments:
'*** command (IN): DDE command string sent from Excel
'*** args (OUT): array of strings containing the command parameters
'*** retcode (OUT): numbers 1 - 6 indicating type of command or error.
'**************************************************************************
Private Sub check_DDEcommandtype(command As String, parameter() As String, _
retcode As Byte)
Dim temp As String
Dim i As Integer
retcode = 0
'*** Separate the command parameter string
For i = 1 To 7
parameter(i) = LCase(getword(command, i, "¤"))
'*** The DDE adds two characters to the end of the string
'*** CHECK THIS UP!!!
If i = 7 Then
temp = LCase(getword(command, i, "¤"))
parameter(i) = Left(temp, Len(temp) - 2)
End If
Next
'*** Analysis with no condition
If parameter(1) <> "#" And parameter(2) <> "#" And parameter(3) <> "#" And _
parameter(4) <> "#" And parameter(5) = "#" And parameter(6) = "#" And _
parameter(7) = "#" Then _
retcode = 2
'*** Analysis with condition on the analysis variable
If parameter(1) <> "#" And parameter(2) <> "#" And parameter(3) <> "#" And _
parameter(4) <> "#" And parameter(5) = "#" And parameter(6) <> "#" And _
parameter(7) <> "#" Then _
retcode = 3
'*** Analysis with condition on the selection variable
If parameter(1) <> "#" And parameter(2) <> "#" And parameter(3) <> "#" And _
parameter(4) <> "#" And parameter(5) <> "#" And parameter(6) <> "#" And _
parameter(7) <> "#" Then _
retcode = 4
If parameter(1) = "!selection" Then
'*** Clear
If parameter(5) = "clear" Then retcode = 5
'*** Global condition
If parameter(5) <> "#" And parameter(6) <> "#" And parameter(7) <> "#" Then _
retcode = 1
End If
If parameter(1) = "[dummy]" And parameter(4) <> "#" Then retcode = 6
End Sub
'**************************************************************************
'*** Function calculate_statistic(X, Y) returns the result of calculating
'*** the statistic Y for variable X.
'*** The result takes into account the global selections that are set by
'*** frmGlobalSelection (the SelLst structure).
'**************************************************************************
Private Function calculate_statistic(variable As String, statistic As String) _
As Double
Dim vartype As String
Dim sum As Double, minval As Double, maxval As Double, ssq As Double, DENOM As Double
Dim n As Long, i As Long
'*** Initialize the temporary vector
Call prepare_temp(variable)
vartype = Left(variable, 2)
Select Case vartype
'*** Individual variable
Case "i_"
Select Case UCase(statistic)
Case "MEAN"
sum = 0
For i = 1 To m_icount
sum = sum + temp(i) * select_i(i)
Next
DENOM = CDbl(L_SUMVEC(select_i(1), m_icount))
If DENOM > 0 Then
calculate_statistic = sum / DENOM
Else
calculate_statistic = 0
End If
Case "SUM"
sum = 0
For i = 1 To m_icount
sum = sum + temp(i) * select_i(i)
Next
calculate_statistic = sum * m_weight
Case "COUNT"
calculate_statistic = L_SUMVEC(select_i(1), m_icount) * m_weight
Case "MIN"
minval = 1E+100
For i = 1 To m_icount
If select_i(i) = 1 Then
If temp(i) < minval Then minval = temp(i)
End If
Next
calculate_statistic = minval
Case "MAX"
maxval = -1E+100
For i = 1 To m_icount
If select_i(i) = 1 Then
If temp(i) > maxval Then maxval = temp(i)
End If
Next
calculate_statistic = maxval
Case "STD"
sum = 0
ssq = 0
n = 0
For i = 1 To m_icount
sum = sum + temp(i) * select_i(i)
ssq = ssq + temp(i) ^ 2 * select_i(i)
n = n + select_i(i)
Next
DENOM = CDbl(n ^ 2 - n)
calculate_statistic = Sqr((n * ssq - sum ^ 2) / DENOM)
Case Else
status "DDE ERROR: Unknown statistic: " & statistic
End Select
'*** Household variable
Case "h_"
Select Case UCase(statistic)
Case "MEAN"
sum = 0
For i = 1 To m_hcount
sum = sum + temp(i) * select_h(i)
Next
DENOM = CDbl(L_SUMVEC(select_h(1), m_hcount))
If DENOM > 0 Then
calculate_statistic = sum / DENOM
Else
calculate_statistic = 0
End If
Case "SUM"
sum = 0
For i = 1 To m_hcount
sum = sum + temp(i) * select_h(i)
Next
calculate_statistic = sum * m_weight
Case "COUNT"
calculate_statistic = L_SUMVEC(select_h(1), m_hcount) * m_weight
Case "MIN"
minval = 1E+100
For i = 1 To m_hcount
If select_h(i) = 1 Then
If temp(i) < minval Then minval = temp(i)
End If
Next
calculate_statistic = minval
Case "MAX"
maxval = -1E+100
For i = 1 To m_hcount
If select_h(i) = 1 Then
If temp(i) > maxval Then maxval = temp(i)
End If
Next
calculate_statistic = maxval
Case "STD"
sum = 0
ssq = 0
n = 0
For i = 1 To m_hcount
sum = sum + temp(i) * select_h(i)
ssq = ssq + temp(i) ^ 2 * select_h(i)
n = n + select_h(i)
Next
DENOM = CDbl(n * (n - 1))
calculate_statistic = Sqr((n * ssq - sum ^ 2) / DENOM)
Case Else
status "DDE ERROR: Unknown statistic: " & statistic
End Select
'*** Macro variable
'*** NOTE: The actual macro value is reported, statistic is ignored
Case "m_"
calculate_statistic = get_macro_value(variable)
Case Else
status "DDE ERROR: Unknown variable type: " & variable
End Select
End Function
'****************************************************************************
'*** Sub send2excel() sends the string value, using DDE, to the Excel
'*** worksheet cell specified by destination.
'****************************************************************************
Private Sub send2excel(destination As String, value As String)
'*** Topic: excel|sheet
frmSESIMDDE.txtDDE_out.LinkTopic = "excel|" & getword(destination, 1, "_")
'*** Manual link - has to be poked
frmSESIMDDE.txtDDE_out.LinkMode = 2
'*** Item: cell
frmSESIMDDE.txtDDE_out.LinkItem = getword(destination, 2, "_")
frmSESIMDDE.txtDDE_out.text = value
frmSESIMDDE.txtDDE_out.LinkPoke
End Sub