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