'Begin Description 'infofreq.SBS 2007/2/10 '変数選択.sbs '注意:変数選択/のときにクリックの間隔を開けるようにする。 '(つまり,ダブルクリックは無効) '変数指定はその変数をクリックすると移動する。また,「10 >>」ボタンは前に指定した変数の次の変数から10変数を移動させる。(前の指定がなければ最初から10変数) 'End Description 'require variables to be dimensioned before use Option Explicit Global strVarsSelected() As String Global allvars() As String Global numvar As Integer '選択した変数の数 Global na As Integer '総カテゴリ数 Global strmacro As String Global draft As Boolean Global selold As Integer Global strSPSSPath As String,strFilepath As String Global datamodified As Boolean Global stitle As String Global inifile As String Global macroexec As String Rem 追加変数 'demonstrates use of the MultipleVariableSelectionDialog function Sub Main Rem タイトル・ファイルの設定↓ stitle="度数分布表情報量" 'ここに処理タイトルを入れる。 inifile="infofreq.ini" 'ここに変数名保存のファイル名を入れる。 *.ini 形式がよい Rem タイトル・ファイルの設定↑ macroexec="infofreq" 'macriexec が単純なら前で指定するだけでいい(ex. "normtest var=" 'spsswin.exe のあるパスを得る 最後に \ つき strSPSSPath = objSpssApp.GetSPSSPath ' MsgBox strSPSSPath 'the function result is True if one or more variables are selected 'False if the user presses cancel If MultipleVariableSelectionDialog(strVarsSelected()) Then numvar=UBound(strVarsSelected) Call execcommand Else MsgBox "Operation Cancelled.", vbExclamation, _ "No Variables Selected" End If End Sub 'we'll put the selected variable names in the array passed as a parameter 'we'll return False as the function result if the user cancels, 'True if the user pressed OK - which we only allow after at least one 'variable is selected. Function MultipleVariableSelectionDialog(strVarsSelected() As String) As Boolean Rem 多変数選択ダイアログ 'we'll pass string arrays to the dialog's listboxes 'actually, the dialog function will initialize the arrays 'but we have to pass it a string array or there will be a type mismatch. Dim strVariables() As String ReDim strVariables(0) 're-initialize the Selected array, to make sure it isn't empty. ReDim strVarsSelected(0) 'we'll make things nice by displaying the name of the data file ' Dim strFilePath As String 'the path to the file strFilepath = objSpssApp.Documents.GetDataDoc(0).GetDocumentPath ' MsgBox strFilePath ' End 'データに修正があったか? datamodified=objSpssApp.Documents.GetDataDoc(0).Modified 'MsgBox strFilePath 'if the file hasn't been saved If strFilepath = "" Then strFilepath = "(Untitled)" End If 'MsgBox strFilePath ' End Rem ダイアログボックス使用リストの再定義 (global 変数) ' Call InitVariables(vnum()) 'Define and put up the dialog. Rem ダイアログボックス定義 'To edit the dialog: position the cursor between Begin Dialog and 'End Dialog, then activate the Dialog Editor. 'Note that the dialog editor created a template with ListArray() 'as the ListBox parameter; it's been replaced by strVariables. 'Right-click on an item to edit its properties, or use the toolbar button. 'Use the << and >> arrows to cycle through items. 'Add a function name to the UserDialog's Dialog Function property, 'and when you save the dialog it will offer to generate the skeleton 'of the dialog monitor function. See VarListDialogMonitor function, below. Begin Dialog UserDialog 490,287,"infofreqスクリプト 度数分布表の情報量.",.VarListDialogFunc ' %GRID:10,7,1,1 GroupBox 10,7,470,189,strFilepath,.GroupBox1 PushButton 470,203,10,7,"",.no PushButton 210,35,80,21," All >> ",.PushButtonAdd PushButton 210,119,80,21," << All ",.PushButtonRemove ListBox 20,21,180,168,strVariables(),.ListBoxVars ListBox 300,21,160,133,strVarsSelected(),.ListBoxVarsSelected PushButton 210,63,80,21," 10 >>",.PushButtonAdd10 PushButton 300,161,80,21,"OK",.OK ' PushButton 210,161,80,21,"Cancel",.Cancel CancelButton 210,161,80,21,.Cancel OptionGroup .freq OptionButton 40,217,70,14,"度数" OptionButton 40,238,50,14,"% " Text 30,196,80,14,"出力",.Text1 Text 140,196,80,14,"カテゴリ数",.Text2 OptionGroup .cat OptionButton 140,217,90,14,"全部同じ" OptionButton 140,238,90,14,"個別 " Text 260,196,90,14,"並べ替え",.Text3 OptionGroup .sort OptionButton 260,217,90,14,"情報量順" OptionButton 260,238,90,14,"出現順 " End Dialog 'the Cancel button will cause an error when pressed, 'so we need to set up error handling before putting up the dialog. 'On Error GoTo UserCancel Rem ダイアログボックス初期値定義 ↑ Dim dlg As UserDialog 'this actually puts up the dialog. Dialog dlg ' dlg.freq=1 ' dlg.Group2=1 ' dlg.perc=0 dlg.cat=1 ' dlg.all=0 ' dlg.sort=0 ' dlg.occur=1 'On Error GoTo UserCancel 'we used a utility function called from the dialog monitor 'to store the variables. Request them now. strVarsSelected() = SelectedVariableArray("", False) 'return true since user hit OK MultipleVariableSelectionDialog = True Exit Function 'here's the error handler UserCancel: 'in other circumstances, we might put up a message box. 'Here, we'll return an empty string. It's up to the caller 'of the function to respond appropriately. Debug.Print "Error" & Err & vbCrLf & Err.Description ReDim strVarsSelected(0) MultipleVariableSelectionDialog = False End Function Rem See DialogFunc help topic for more information. 'the Dialog Monitor is called repeatedly while the dialog is displayed. 'when it returns False, the dialog will close. Function VarListDialogFunc(DlgItem$, Action%, SuppValue%) As Boolean 'static variables retain their values between function invocations 'we'll use these to track which variables are selected Static strVars() As String Static strVarsSelected() As String Static selnum As Integer Static selold As Integer 'loop control variable Dim i As Integer 'the item selected Dim intDlgItem As Integer Dim strfilepath2 As String Select Case Action% Rem dialog box 初期化 Case 1 ' Dialog box 初期化 Call InitVariables(strVars) If Dir$( strSPSSPath & inifile)<>"" Then Rem '既定値の読み込み ----------------------------------------------- Dim aru As Boolean,a As String ,j As Integer, k As Integer,nb As Integer ReDim strVarsSelected(0) Open strSPSSPath & inifile For Input As #1 Rem 前の初期値のリスト(データが違っていても使用する)↓ Input #1,i DlgValue "freq",i Input #1,i DlgValue "sort",i Input #1,i DlgValue "cat",i Rem 前の初期値のリスト↑ Input #1,nb Dim ustrvars As Integer If nb<=UBound(strVars()) Then For i=0 To nb Line Input #1,a aru=False ustrvars=UBound(strVars()) For j=0 To ustrvars If strVars(j)= a Then aru=True ' Debug.Print ustrvars ' Debug.Print strVars(ustrvars) For k=j To (ustrvars-1) strVars(k)=strVars(k+1) Next k If ustrvars>=1 Then ReDim Preserve strVars(ustrvars - 1) Else ReDim strVars(0) End If If strVarsSelected(0)="" Then strVarsSelected(0)=a Else ustrvars=UBound(strVarsSelected())+1 ReDim Preserve strVarsSelected(ustrvars) strVarsSelected(ustrvars)=a End If Exit For End If Next j If aru=False Then Exit For Next i Rem データが違うと無効な初期値のリスト↓ Rem データが違うと無効な初期値のリスト↑ Else aru=False End If Close #1 If aru=False Then ReDim strVarsSelected(0) ReDim strVars(0) Call InitVariables(strVars()) End If DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgListBoxArray "ListBoxVars", strVars() Rem '既定値読み込み終了--------------------------------------------- Else ReDim strVarsSelected(0) End If ' ReDim strVarsSelected(0) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() 'DlgEnable "OK", (UBound(strVarsSelected())>0) DlgEnable "OK", (strVarsSelected(0) <> "") DlgEnable "no", False DlgEnable "PushButtonAdd", (strVars(0) <> "") DlgEnable "PushButtonAdd10", (strVars(0) <> "") DlgEnable "PushButtonRemove", (strVarsSelected(0) <> "") Dim objSPSSOptions As ISpssOptions Set objSPSSOptions = objSpssApp.Options ' selold=-1 'while initializing, return True to close the dialog 'VarListDialogFunc = False Rem 値が変更された、ボタンが押された時 Case 2 ' Value changing or button pressed If (DlgValue("ListBoxVars") >= 0) Then selnum=DlgValue("ListBoxVars") selold=selnum DlgEnable "OK", False DlgEnable "ListBoxVars", False Call MoveItem(DlgValue("ListBoxVars"), strVars(), strVarsSelected()) DlgListBoxArray "ListBoxVars", strVars() ' MsgBox CStr(VarType(UBound(strVars()))) DlgValue "ListBoxVars",selnum+5 If selnum > CInt(UBound(strVars())) Then selnum=selnum-1 Else If selnum+5< UBound(strVars()) Then DlgValue "ListBoxVars",selnum+5 Else DlgValue "ListBoxVars",UBound(strVars()) End If End If DlgValue "ListBoxVars",selnum DlgValue "ListBoxVars",-1 DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgValue "ListBoxVarsSelected",UBound(strVarsSelected()) DlgValue "ListBoxVarsSelected",-1 'DlgEnable "OK",(UBound(strVarsSelected())>0) DlgEnable "OK", (strVarsSelected(0) <> "") ' MsgBox CStr(UBound(strVarsSelected())) VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf (DlgValue("ListBoxVarsSelected") >= 0) Then selnum=DlgValue("ListBoxVarsSelected") Call MoveItem(DlgValue("ListBoxVarsSelected"), strVarsSelected(), strVars()) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgValue "ListBoxVarsSelected",selnum+5 If selnum > CInt(UBound(strVarsSelected())) Then selnum=selnum-1 Else If selnum+5< UBound(strVarsSelected()) Then DlgValue "ListBoxVarsSelected",selnum+5 Else DlgValue "ListBoxVarsSelected",UBound(strVarsSelected()) End If End If DlgValue "ListBoxVarsSelected",selnum DlgValue "ListBoxVarsSelected",-1 DlgValue "ListBoxVars",UBound(strVars()) DlgValue "ListBoxVars",-1 'DlgEnable "OK", (UBound(strVarsSelected()) > 0) DlgEnable "OK", (strVarsSelected(0) <> "") VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf DlgItem$="PushButtonAdd10" Then DlgEnable "PushButtonAdd10", False selnum=selold If selnum<0 Then selnum=0 Call MoveItem10(selnum, strVars(), strVarsSelected()) DlgListBoxArray "ListBoxVars", strVars() ' MsgBox CStr(VarType(UBound(strVars()))) DlgValue "ListBoxVars",selnum+5 If selnum > CInt(UBound(strVars())) Then selnum=selnum-1 Else If selnum+5< UBound(strVars()) Then DlgValue "ListBoxVars",selnum+5 Else DlgValue "ListBoxVars",UBound(strVars()) End If End If DlgValue "ListBoxVars",selnum DlgValue "ListBoxVars",-1 DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() DlgValue "ListBoxVarsSelected",UBound(strVarsSelected()) DlgValue "ListBoxVarsSelected",-1 DlgEnable "PushButtonAdd10", (strVars(0) <> "") DlgEnable "OK", (strVars(0) <> "") VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf DlgItem$ = "PushButtonRemove" Then Call moveall(strVarsSelected(), strVars()) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() selnum=-1 DlgEnable "OK", False VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf (DlgItem$ = "PushButtonAdd") Then Call moveall( strVars(), strVarsSelected()) DlgListBoxArray "ListBoxVars", strVars() DlgListBoxArray "ListBoxVarsSelected", strVarsSelected() selnum=-1 DlgEnable "OK", (strVarsSelected(0) <> "") VarListDialogFunc = True ' Prevent button press from closing the dialog box ElseIf DlgItem$ = "OK" Then 'store the array, ignore the function result Rem 処理開始 macro書き込み 'strMacro = strMacro + "hayasi3 var= " &vbCrLf ''Dim i As Integer 'For i=0 To numvar 'strMacro = strMacro + strVarsSelected(i) &vbCrLf 'Next i 'strMacro = strMacro + '.' &vbCrLf strmacro=strmacro+"/freq="+ Str(DlgValue("freq")+1) strmacro=strmacro+"/sort="+ Str(DlgValue("sort")+1) strmacro=strmacro+"/type="+ Str(DlgValue("cat")+1) ' strmacro=strmacro+"/zero="+ DlgText("zero") 'If DlgValue("freq")=1 Then ' strmacro=strmacro+"/freq= 1" ' Else ' strmacro=strmacro+"/temp= NO" ' End If Rem inifile 書き込み Open strSPSSPath & inifile For Output As #1 Rem  初期値リスト書き込み↓ Print #1,DlgValue("freq") Print #1,DlgValue("sort") Print #1,DlgValue("cat") Rem  初期値リスト書き込み↑ Rem  使用変数書き込み Print #1,UBound(strVarsSelected()) For i=1 To UBound(strVarsSelected())+1 Print #1,strVarsSelected(i-1) Next i Rem  ファイルが違うとき無効の初期値のリスト↓ Rem  ファイルが違うとき無効の初期値のリスト↑ Close #1 ' 書き込み終了 ' MsgBox strFilepath Call SelectedVariableArray(strVarsSelected(), True) ElseIf DlgItem$ = "no" Then MsgBox "クリックの間隔が速すぎます。ダブルクリックはしないようにね" VarListDialogFunc = True ' Prevent button press from closing the dialog box ' End If ElseIf DlgItem$ = "Cancel" Then End End If Rem VarListDialogFunc = True ' Prevent button press from closing the dialog box Rem テクストボックス・コンボボックスのテキスト変更 Case 3 ' TextBox or ComboBox text changed Rem Focus 変更 Case 4 ' Focus changed Rem アイドル Case 5 ' Idle DlgEnable "ListBoxVars", (strVars(0) <> "") DlgEnable "PushButtonAdd", (strVars(0) <> "") DlgEnable "PushButtonAdd10",(strVars(0) <> "") DlgEnable "PushButtonRemove", (strVarsSelected(0) <> "") 'DlgEnable "OK",(UBound(strVarsSelected())>0) DlgEnable "OK", (strVarsSelected(0) <> "") VarListDialogFunc = True ' Continue getting idle actions End Select End Function Sub InitVariables(strVars() As String) 'As Variant 'the variable list is a property of the Info object. Dim objInfo As ISpssInfo 'we'll return the array of strings in a variant 'Dim strVars() As String 'loop control variable Dim i As Integer 'we'll need to know how many variables there are Dim intNumVariables As Integer Set objInfo = objSpssApp.SpssInfo 'the variables are indexed by 0 to .NumVariables - 1 intNumVariables = objInfo.NumVariables If intNumVariables > 0 Then 'set aside enough storage for the array ReDim strVars(intNumVariables - 1) ReDim allvars(intNumVariables-1) 'read in the variable names For i = 0 To intNumVariables - 1 'if we preferred, we could work with labels instead, or both strVars(i) = objInfo.VariableAt(i) 'strVars(i) = objInfo.VariableLabelAt(i) 'strVars(i) = objInfo.VariableAt(i) & ": " & objInfo.VariableLabelAt(i) allvars(i) = objInfo.VariableAt(i) Next Else 'array with one empty string ReDim strVars(0) ReDim allvars(0) End If 'InitVariables = strVars End Sub Sub moveall( strFrom() As String, strTo() As String) Dim i As Integer Dim intUpper As Integer intUpper=UBound(allvars) Debug.Print intUpper; allvars(intUpper) ReDim Preserve strTo(intUpper ) For i=0 To intUpper strTo(i)=allvars(i) Next i ReDim strFrom(0) End Sub 'utility procedure for moving an item, omits checks - because it's only 'called from the dialog function, intItem will be valid Sub MoveItem(intItem As Integer, strFrom() As String, strTo() As String) Dim i As Integer Dim intUpper As Integer '*** add the item to the destination array *** intUpper = UBound(strTo) Debug.Print intUpper; intItem; strTo(intUpper) If strTo(intUpper) = "" Then strTo(intUpper) = strFrom(intItem) Else 'make the array larger, but keep the current contents ReDim Preserve strTo(intUpper + 1) strTo(intUpper + 1) = strFrom(intItem) End If '*** remove the item from the source array *** intUpper = UBound(strFrom) 'copy the items above the removed item down one position For i = intItem To intUpper - 1 strFrom(i) = strFrom(i + 1) Next If intUpper > 0 Then 'keep all but the last element ReDim Preserve strFrom(intUpper - 1) Else 'this will re-initialize the array to contain one empty string ReDim strFrom(0) End If End Sub Sub MoveItem10(intItem As Integer, strFrom() As String, strTo() As String) Dim i As Integer Dim intUpper As Integer Dim imove As Integer, k As Integer '*** add the item to the destination array *** imove=10 If (UBound(strFrom)-intItem) < 10 Then imove=UBound(strFrom)-intItem+1 For k=0 To imove-1 intUpper = UBound(strTo) ' Debug.Print intUpper; intItem; strTo(intUpper) If strTo(intUpper) = "" Then strTo(intUpper) = strFrom(intItem) Else 'make the array larger, but keep the current contents ReDim Preserve strTo(intUpper + 1) strTo(intUpper + 1) = strFrom(intItem+k) End If Next k '*** remove the item from the source array *** intUpper = UBound(strFrom) 'copy the items above the removed item down one position If (intUpper >= intItem+imove) Then For i = intItem To intUpper - imove strFrom(i) = strFrom(i + imove) Next End If If intUpper-imove > 0 Then 'keep all but the last element ReDim Preserve strFrom(intUpper - imove) Else 'this will re-initialize the array to contain one empty string ReDim strFrom(0) End If End Sub 'this is a cheap dodge which lets us avoid using a global variable 'to pass the array out of the dialog monitor. This function stores 'its parameter when called with blnStore = True, and returns whatever 'was stored previously as the function result. This makes it easier 'to encapsulate code, since when copying the code for re-use, we 'don't need to create and follow instructions to add a global variable 'to the project in order for the code to work. Function SelectedVariableArray(vntStore As Variant, blnStore As Boolean) As Variant Static vntStored As Variant SelectedVariableArray = vntStored 'we refuse to store anything but an array of strings If blnStore Then If IsArray(vntStore) Then If VarType(vntStore(0)) = vbString Then vntStored = vntStore End If End If End If End Function Sub execcommand 'マクロ命令記述部 ********************************************. Dim strCommand As String Call macrocompile() strCommand = strCommand + macroexec &vbCrLf 'macro が単純なら前で指定するだけでいい Dim i As Integer strCommand= strCommand+"var=" For i=0 To numvar strCommand = strCommand + strVarsSelected(i) &vbCrLf Next i strCommand = strCommand + strmacro+ "." &vbCrLf objSpssApp.ExecuteCommands strCommand , False End Sub '**************************************************************. 'シンタックス部挿入部分 ↓ *******************************************************. Sub macrocompile() Dim strCommand As String strCommand = strCommand + "*評定段階尺度データの情報量計算マクロ。." &vbCrLf strCommand = strCommand + "define infofreq (var=!charend('/')" &vbCrLf strCommand = strCommand + " /type=!default(1)!charend('/') /* 1=全評定尺度の最大値がカテゴリ数 else=各項目の最大値 */" &vbCrLf strCommand = strCommand + " /freq=!default(1)!charend('/') /* 1=頻度 else=% */" &vbCrLf strCommand = strCommand + " /sort=!default(2)!charend('/') /* 1=ソートする else=ソートしない */" &vbCrLf strCommand = strCommand + " )." &vbCrLf strCommand = strCommand + "preserve." &vbCrLf strCommand = strCommand + "set mxloop= 2000." &vbCrLf strCommand = strCommand + "matrix." &vbCrLf strCommand = strCommand + "get x /file=*/variables=!var/missing=omit/sysmis=omit/names=nx." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*type 1 すべての変数のカテゴリ数が同じ。既定値。." &vbCrLf strCommand = strCommand + "*compute type=1." &vbCrLf strCommand = strCommand + "compute type=!type." &vbCrLf strCommand = strCommand + "!if (!type=1) !then" &vbCrLf strCommand = strCommand + " print type/title=""すべての変数のカテゴリ数が同じ(すべての変数における最大カテゴリ数)""." &vbCrLf strCommand = strCommand + "!else" &vbCrLf strCommand = strCommand + " print type/title=""個々の変数の最大カテゴリ数""." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*tbl 1 頻度表 2=パーセンテージ表。." &vbCrLf strCommand = strCommand + "compute tbl=!freq." &vbCrLf strCommand = strCommand + "!if (!freq=1) !then" &vbCrLf strCommand = strCommand + " print tbl/title=""頻度表""." &vbCrLf strCommand = strCommand + "!else" &vbCrLf strCommand = strCommand + " print tbl/title=""パーセンテージ表""." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*sort 1 ソートする 2=ソートしない." &vbCrLf strCommand = strCommand + "compute srt=!sort." &vbCrLf strCommand = strCommand + "!if (!sort=1) !then" &vbCrLf strCommand = strCommand + " print srt/title=""相対情報量順""." &vbCrLf strCommand = strCommand + "!else" &vbCrLf strCommand = strCommand + " print srt/title=""出現変数順""." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "print nx/format=a8." &vbCrLf strCommand = strCommand + "*design の出力を1,2,3...とするため num." &vbCrLf strCommand = strCommand + "compute num={1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22," &vbCrLf strCommand = strCommand + " 23,24,25,26,27,28,29,30}." &vbCrLf strCommand = strCommand + "compute num=t(num)." &vbCrLf strCommand = strCommand + "compute vnum={""v1"",""v2"",""v3"",""v4"",""v5"",""v6"",""v7"",""v8"",""v9"",""v10"",""v11"",""v12"",""v13"",""v14"",""v15""}." &vbCrLf strCommand = strCommand + "*print vnum/format a8." &vbCrLf strCommand = strCommand + "compute #nvar=ncol(nx)." &vbCrLf strCommand = strCommand + "compute nsample=nrow(x)." &vbCrLf strCommand = strCommand + "print nsample/title=""サンプルサイズ""." &vbCrLf strCommand = strCommand + "*全データの最大カテゴリ数 maxcat." &vbCrLf strCommand = strCommand + "compute maxcat=mmax(x)." &vbCrLf strCommand = strCommand + "compute mx=make(1,(1+maxcat),0)." &vbCrLf strCommand = strCommand + "compute icat=make(1,1,0)." &vbCrLf strCommand = strCommand + "*カテゴリの1,0展開 結果を d に 反応変数." &vbCrLf strCommand = strCommand + "compute x1=x(:,(#nvar))." &vbCrLf strCommand = strCommand + "compute gmax=cmax(x1)." &vbCrLf strCommand = strCommand + "compute x1={num(1:gmax,1);x1}." &vbCrLf strCommand = strCommand + "compute #row1=nsample+gmax." &vbCrLf strCommand = strCommand + "compute d=design(x1)." &vbCrLf strCommand = strCommand + "compute d=d((gmax+1):#row1,:)." &vbCrLf strCommand = strCommand + "compute ncat=ncol(d)." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*print ncat." &vbCrLf strCommand = strCommand + "*合成変数のダミー変数." &vbCrLf strCommand = strCommand + "loop c = 1 to #nvar." &vbCrLf strCommand = strCommand + "*compute c=1." &vbCrLf strCommand = strCommand + " compute aa=make(nsample,1,0)." &vbCrLf strCommand = strCommand + " compute aa=aa+x(:,c)." &vbCrLf strCommand = strCommand + " compute #nnum=mmax(num)." &vbCrLf strCommand = strCommand + " compute #mxaa=mmax(aa)." &vbCrLf strCommand = strCommand + " do if (#mxaa>#nnum)." &vbCrLf strCommand = strCommand + " loop inum=(#nnum+1) to #mxaa." &vbCrLf strCommand = strCommand + " compute num={num;inum}." &vbCrLf strCommand = strCommand + " end loop." &vbCrLf strCommand = strCommand + " end if." &vbCrLf strCommand = strCommand + "*カテゴリの1,0展開 結果を z に." &vbCrLf strCommand = strCommand + " compute cmaxs=cmax(aa)." &vbCrLf strCommand = strCommand + " compute x1=aa." &vbCrLf strCommand = strCommand + "* compute x1={num(1:cmaxs,1);x1}." &vbCrLf strCommand = strCommand + " compute x1={num(1:maxcat,1);x1}." &vbCrLf strCommand = strCommand + " compute z=design(x1)." &vbCrLf strCommand = strCommand + "* compute #row1=nsample+cmaxs." &vbCrLf strCommand = strCommand + "* compute z=z((cmaxs+1):#row1,:)." &vbCrLf strCommand = strCommand + " compute #row1=nsample+maxcat." &vbCrLf strCommand = strCommand + " compute z=z((maxcat+1):#row1,:)." &vbCrLf strCommand = strCommand + "*個々の計算." &vbCrLf strCommand = strCommand + " compute freq=csum(z)." &vbCrLf strCommand = strCommand + "* print freq." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "*print nx(c)/format a8." &vbCrLf strCommand = strCommand + "********************************." &vbCrLf strCommand = strCommand + "compute as=0." &vbCrLf strCommand = strCommand + "do if (cmaxs0)." &vbCrLf strCommand = strCommand + " * print freq(1,cmaxs+1)." &vbCrLf strCommand = strCommand + " compute as=1." &vbCrLf strCommand = strCommand + " end if." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "do if ((ncol(freq)>maxcat) or (as=1))." &vbCrLf strCommand = strCommand + " print nx(c)/title=""0以下の値が入ってます。要データチェック。この処理は暫定です。""/format= a8." &vbCrLf strCommand = strCommand + " print freq/cnames=vnum." &vbCrLf strCommand = strCommand + " compute freq=freq(1,1:maxcat)." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "********************************." &vbCrLf strCommand = strCommand + "*クロス表内に0がある場合." &vbCrLf strCommand = strCommand + "compute freq0=freq." &vbCrLf strCommand = strCommand + "compute zero=.50." &vbCrLf strCommand = strCommand + " do if (all(freq)=0)." &vbCrLf strCommand = strCommand + "* compute z0=freq1)." &vbCrLf strCommand = strCommand + " compute freq0=freq0&/rsum(freq0)*100." &vbCrLf strCommand = strCommand + "end if." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "compute mm={info,freq0}." &vbCrLf strCommand = strCommand + "compute mx={mx;mm}." &vbCrLf strCommand = strCommand + "compute icat={icat;kend}." &vbCrLf strCommand = strCommand + "end loop." &vbCrLf strCommand = strCommand + "compute mx=mx(2:(ncol(nx)+1),:)." &vbCrLf strCommand = strCommand + "*print mx." &vbCrLf strCommand = strCommand + "compute icat=icat(2:(ncol(nx)+1),:)." &vbCrLf strCommand = strCommand + "*print icat." &vbCrLf strCommand = strCommand + "compute vname={""name"",""info"",vnum(1:maxcat),""icat""}." &vbCrLf strCommand = strCommand + "save {t(nx),mx,icat}/outfile=*/names=vname/string=""name""." &vbCrLf strCommand = strCommand + "end matrix." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "***********************************." &vbCrLf strCommand = strCommand + "compute poinit=2**info." &vbCrLf strCommand = strCommand + "compute rinfo=info/(ln(icat)/ln(2))." &vbCrLf strCommand = strCommand + "!let !ttl= ""評定の分布(""." &vbCrLf strCommand = strCommand + "**********************." &vbCrLf strCommand = strCommand + "!if (!freq=1) !then" &vbCrLf strCommand = strCommand + " format info to icat(f6.0)." &vbCrLf strCommand = strCommand + " !let !ttl=!concat(!ttl,""頻度) と情報量("")." &vbCrLf strCommand = strCommand + "!else" &vbCrLf strCommand = strCommand + " format info to icat(f6.1)." &vbCrLf strCommand = strCommand + " format icat(f6.0)." &vbCrLf strCommand = strCommand + " !let !ttl=!concat(!ttl,""パーセンテージ) と情報量("")." &vbCrLf strCommand = strCommand + "!ifend." &vbCrLf strCommand = strCommand + "**********************." &vbCrLf strCommand = strCommand + "*sort 1 ソートする 2=ソートしない." &vbCrLf strCommand = strCommand + "compute srt=!sort." &vbCrLf strCommand = strCommand + "!if (!sort=1) !then" &vbCrLf strCommand = strCommand + " sort case by rinfo." &vbCrLf strCommand = strCommand + " !let !ttl=!quote(!concat(!ttl,""相対情報量順)""))." &vbCrLf strCommand = strCommand + "!else" &vbCrLf strCommand = strCommand + " !let !ttl=!quote(!concat(!ttl,""出現変数順)""))." &vbCrLf strCommand = strCommand + "!ifend" &vbCrLf strCommand = strCommand + "**********************." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "format info rinfo poinit(f8.2)." &vbCrLf strCommand = strCommand + "var labels" &vbCrLf strCommand = strCommand + "name ""変数名""/" &vbCrLf strCommand = strCommand + "poinit ""実質使用評定段階""/" &vbCrLf strCommand = strCommand + "rinfo ""相対情報量""/" &vbCrLf strCommand = strCommand + "info ""情報量""/" &vbCrLf strCommand = strCommand + "icat ""総評定段階数""." &vbCrLf strCommand = strCommand + "set ovar=labels." &vbCrLf strCommand = strCommand + "" &vbCrLf strCommand = strCommand + "SUMMARIZE" &vbCrLf strCommand = strCommand + " /TABLES=name poinit rinfo info to icat " &vbCrLf strCommand = strCommand + " /FORMAT=VALIDLIST NOCASENUM noTOTAL " &vbCrLf strCommand = strCommand + " /TITLE=!ttl" &vbCrLf strCommand = strCommand + " /MISSING=VARIABLE" &vbCrLf strCommand = strCommand + " /CELLS=NONE." &vbCrLf strCommand = strCommand + "restore." &vbCrLf strCommand = strCommand + "!enddefine." &vbCrLf strCommand = strCommand + "" &vbCrLf objSpssApp.ExecuteCommands strCommand , False End Sub 'シンタックス部挿入部分 ↑ *******************************************************.