frmdraw.frm

SPSS的实战介绍

  ReDim strListOfVars(intNumVariables) As String
  ReDim bolSelected(intNumVariables) As Integer
  ReDim intArrayIndex(intNumVariables) As Integer
  
  intNumNotSel = 0
  For intI = 0 To intNumVariables
      strListOfVars(intNumNotSel) = objSPSSInfo.VariableAt(intI)
      lstVarSource.AddItem (strListOfVars(intNumNotSel))
      intNumNotSel = intNumNotSel + 1
    bolSelected(intI) = 1
    intArrayIndex(intI) = intI
  Next intI
  
  Call NewLists
End Sub
Private Sub cmdReset_Click()
  Dim intListCountSource As Integer
  Dim intListCountFirst As Integer
  Dim intListCountSecond As Integer
  
  '如果三个列表框均为空，给出出错信息
  intListCountSource = lstVarSource.ListCount
  intListCountFirst = lstVarFirst.ListCount
  intListCountSecond = lstVarSecond.ListCount
  If intListCountSource < 1 And intListCountFirst < 1 And intListCountSecond < 1 Then
    MsgBox (strFileNotOpenOrNull)
    Exit Sub
  End If
  
  Call GetVariables
  With cmdMove1
   .Enabled = True
   .Caption = ">>"
  End With
  With cmdMove2
    .Enabled = True
    .Caption = ">>"
  End With
  
  If (lstVarFirst.List(0) <> strVarFirst) Then bolVariableChanged = True
  If (lstVarSecond.List(0) <> strVarSecond) Then bolVariableChanged = True

End Sub

Private Sub cmdYes_Click()
  Dim intNum As Integer
  Dim intCount As Integer
  Dim intI As Integer
  Dim strMap As String
  
  bolFileChanged = False
  bolVariableChanged = False
  
  '判断文件是否已经打开，或是否为空；是否已经选择变量
  intListCountSource = lstVarSource.ListCount
  intListCountFirst = lstVarFirst.ListCount
  intListCountSecond = lstVarSecond.ListCount
  If intListCountSource < 1 And intListCountFirst < 1 And intListCountSecond < 1 Then
    MsgBox (strFileNotOpenOrNull)
    Exit Sub
  End If
  If intListCountFirst < 1 Or intListCountSecond < 1 Then
    MsgBox (strVariableFirst)
    Exit Sub
  End If
  
  '记录上次操作时的变量名，用于判断后面操作中的变量是否已经改变
  strVarFirst = lstVarFirst.List(0)
  strVarSecond = lstVarSecond.List(0)

  '创建新的输出浏览器窗口，不可见
  Set objOutputDoc = objSpssApp.NewOutputDoc
  objOutputDoc.Visible = False

  '利用Syntax命令过程生成交互条图和散点图
  Call DrawIGraphBar
  Call DrawIGraphScaplot

  '在输出浏览器中获取交互图对象
  Set objDocuments = objSpssApp.Documents
  intCount = objDocuments.OutputDocCount
  Set objOutputItems = objOutputDoc.Items

  intNum = objOutputItems.Count
  For intI = 0 To intNum - 1
    Set objOutputItem = objOutputItems.GetItem(intI)
    If objOutputItem.SPSSType = 10 Then
      Set objIGraph = objOutputItem.GetIGraphOleObject
      Exit For
    End If
  Next intI
  
  '输出图形
  strMap = objOutputDoc.ExportCharts(0, App.Path & "\IGraph.bmp", "Windows Bitmap")
  
  '释放对象
  objOutputItem.Deactivate
  
  bolDrawOrNot = True
  
End Sub

Private Sub Form_Initialize()
  '测试Spss应用程序是否正在运行
  On Error Resume Next
  '如果Spss已经运行，则用GetObject函数获取对象
  Set objSpssApp = GetObject(, "Spss.Application")
  If Err <> 0 Then       '如果Spss没有运行
    '利用CreateObject函数创建Spss对象的实例
    Set objSpssApp = CreateObject("Spss.Application")
  End If
  
  bolDrawOrNot = False
  bolFileChanged = False
  
End Sub

Private Sub lstVarSource_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  cmdMove1.Caption = ">>"
  cmdMove2.Caption = ">>"
  If lstVarFirst.ListCount > 1 Then
    cmdMove1.Enabled = False
  End If
  If lstVarSecond.ListCount > 1 Then
    cmdMove2.Enabled = False
  End If
End Sub

Private Sub lstVarFirst_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  cmdMove1.Enabled = True
  cmdMove1.Caption = "<<"
End Sub

Private Sub lstVarSecond_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  cmdMove2.Enabled = True
  cmdMove2.Caption = "<<"
End Sub
Private Sub cmdMove1_Click()
  Dim intSelIndex As Integer
  Dim I As Integer
    
  '判断文件是否已经打开，或是否为空；是否已经选择变量
  intListCountSource = lstVarSource.ListCount
  intListCountFirst = lstVarFirst.ListCount
  intListCountSecond = lstVarSecond.ListCount
  If intListCountSource < 1 And intListCountFirst < 1 And intListCountSecond < 1 Then
    MsgBox (strFileNotOpenOrNull)
    Exit Sub
  End If
  
  '根据cmdMove1按钮的标题来确定获取变量还是剔除变量
  Select Case cmdMove1.Caption
    Case ">>"
       intSelIndex = lstVarSource.ListIndex
       For I = 0 To UBound(intArrayIndex)
         If (intArrayIndex(I) = intSelIndex) And (bolSelected(I) = 1) Then
           bolSelected(I) = 2
           Exit For
         End If
       Next I
       Call NewLists
    Case "<<"
      cmdMove1.Enabled = True
      intSelIndex = lstVarFirst.ListIndex
      For I = 0 To UBound(intArrayIndex)
        If (intArrayIndex(I) = intSelIndex) And (bolSelected(I) = 2) Then
          bolSelected(I) = 1
          Exit For
        End If
      Next I
      Call NewLists
  End Select
  
  If (lstVarFirst.List(0) <> strVarFirst) Then bolVariableChanged = True
  
End Sub
Private Sub cmdMove2_Click()
  Dim intSelIndex As Integer
  Dim I As Integer
    
  '判断文件是否已经打开，或是否为空；是否已经选择变量
  intListCountSource = lstVarSource.ListCount
  intListCountFirst = lstVarFirst.ListCount
  intListCountSecond = lstVarSecond.ListCount
  If intListCountSource < 1 And intListCountFirst < 1 And intListCountSecond < 1 Then
    MsgBox (strFileNotOpenOrNull)
    Exit Sub
  End If

  '根据cmdMove2按钮的标题确定是获取变量还是剔除变量
  Select Case cmdMove2.Caption
    Case ">>"
       intSelIndex = lstVarSource.ListIndex
       For I = 0 To UBound(intArrayIndex)
         If (intArrayIndex(I) = intSelIndex) And (bolSelected(I) = 1) Then
           bolSelected(I) = 3
           Exit For
         End If
       Next I
       Call NewLists
    Case "<<"
      cmdMove2.Enabled = True
      intSelIndex = lstVarSecond.ListIndex
      For I = 0 To UBound(intArrayIndex)
        If (intArrayIndex(I) = intSelIndex) And (bolSelected(I) = 3) Then
          bolSelected(I) = 1
          Exit For
        End If
      Next I
      Call NewLists
  End Select
  
  If (lstVarSecond.List(0) <> strVarSecond) Then bolVariableChanged = True
  
End Sub
Private Sub ListRefresh(objList As Object, strArray() As String, intNum As Integer)
  Dim intN As Integer
  
  '清除列表框中的内容
  objList.Clear
  '将属于该列表框的选项添加到列表框中
  For intN = 0 To intNum - 1
    objList.AddItem (strArray(intN))
  Next intN
End Sub
Sub NewLists()

    Dim I As Integer
    Dim intNumNotSel As Integer
    Dim intNumSel As Integer
    Dim intNumSel2 As Integer
    
    intNumSel = 0
    intNumNotSel = 0
    intNumSel2 = 0

    ReDim strNotSelVar(intNumNotSel) As String
    ReDim strSelVar(intNumSel) As String
    ReDim strSelVar2(intNumSel2) As String
    
    For I = 0 To UBound(bolSelected)
        '如果变量属于源变量列表框...
        If bolSelected(I) = 1 Then
            ReDim Preserve strNotSelVar(intNumNotSel) As String
            strNotSelVar(intNumNotSel) = strListOfVars(I)
            intArrayIndex(I) = intNumNotSel
            intNumNotSel = intNumNotSel + 1
        '如果变量属于变量一列表框...
        ElseIf bolSelected(I) = 2 Then
            ReDim Preserve strSelVar(intNumSel) As String
            strSelVar(intNumSel) = strListOfVars(I)
            intArrayIndex(I) = intNumSel
            intNumSel = intNumSel + 1
        '如果变量属于变量二列表框...
        Else
            ReDim Preserve strSelVar2(intNumSel2) As String
            strSelVar2(intNumSel2) = strListOfVars(I)
            intArrayIndex(I) = intNumSel2
            intNumSel2 = intNumSel2 + 1
        End If
    Next I
    
    '分别显示三个列表框中的内容
    Call ListRefresh(lstVarSource, strNotSelVar(), intNumNotSel)
    Call ListRefresh(lstVarFirst, strSelVar(), intNumSel)
    Call ListRefresh(lstVarSecond, strSelVar2, intNumSel2)
End Sub
Sub DrawIGraphBar()
    '利用Syntax命令绘交互条图
    Dim strCommand As String
    strCommand = strCommand & "IGRAPH "
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/VIEWNAME='Bar Chart'"
    strCommand = strCommand & "/X1 = VAR("
    strCommand = strCommand & lstVarFirst.List(0)
    strCommand = strCommand & ")"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/Y = VAR("
    strCommand = strCommand & lstVarSecond.List(0)
    strCommand = strCommand & ")"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/COORDINATE = VERTICAL"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/X1LENGTH=3.0"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/YLENGTH=3.0"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/X2LENGTH=3.0"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/CHARTLOOK='NONE'"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/CATORDER VAR("
    strCommand = strCommand & lstVarFirst.List(0)
    strCommand = strCommand & ") (ASCENDING VALUES OMITEMPTY)"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/BAR(MEAN) KEY=OFF SHAPE = RECTANGLE BASELINE = AUTO."
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "EXE."
    strCommand = strCommand & vbCrLf
    objSpssApp.ExecuteCommands strCommand, True
End Sub
Sub DrawIGraphScaplot()
    '利用Syntax命令绘交互散点图
    Dim strCommand As String
    strCommand = strCommand & "IGRAPH"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/VIEWNAME='Scatterplot'"
    strCommand = strCommand & "/X1 = VAR("
    strCommand = strCommand & lstVarFirst.List(0)
    strCommand = strCommand & ")"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/Y = VAR("
    strCommand = strCommand & lstVarSecond.List(0)
    strCommand = strCommand & ")"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/COORDINATE = VERTICAL"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/X1LENGTH=3.0"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/YLENGTH=3.0"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/X2LENGTH=3.0"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/CHARTLOOK='NONE'"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/CATORDER VAR("
    strCommand = strCommand & lstVarFirst.List(0)
    strCommand = strCommand & ") (ASCENDING VALUES OMITEMPTY)"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/SCATTER COINCIDENT = NONE."
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "EXE."
    strCommand = strCommand & vbCrLf
    objSpssApp.ExecuteCommands strCommand, True
End Sub