form1.frm

SPSS的实战介绍

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{EFC0FEDA-2D60-11D4-AD14-8E2B66621F2F}#4.0#0"; "IGraphScoplot.ocx"
Begin VB.Form frmSpssDraw 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "调用SPSS绘图"
   ClientHeight    =   9570
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7770
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   9570
   ScaleWidth      =   7770
   StartUpPosition =   3  '窗口缺省
   Begin IGraphBar.IGBar IGBar1 
      Height          =   3975
      Left            =   1320
      TabIndex        =   15
      Top             =   4440
      Width           =   4935
      _ExtentX        =   8705
      _ExtentY        =   7011
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "退    出"
      Height          =   375
      Left            =   4560
      TabIndex        =   14
      Top             =   8880
      Width           =   1215
   End
   Begin VB.CommandButton cmdDrawBar 
      Caption         =   "绘条形图"
      Height          =   375
      Left            =   1800
      TabIndex        =   7
      Top             =   8880
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   7200
      Top             =   720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdOpen 
      Caption         =   "打开文件..."
      Height          =   375
      Left            =   6120
      TabIndex        =   6
      Top             =   240
      Width           =   1215
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   360
      TabIndex        =   5
      Top             =   240
      Width           =   5535
   End
   Begin VB.CommandButton cmdMove2 
      Caption         =   ">>"
      Height          =   375
      Left            =   3480
      TabIndex        =   4
      Top             =   2520
      Width           =   375
   End
   Begin VB.CommandButton cmdMove1 
      Caption         =   ">>"
      Height          =   420
      Left            =   3480
      TabIndex        =   3
      Top             =   1680
      Width           =   375
   End
   Begin VB.ListBox lstVarSecond 
      Height          =   420
      Left            =   4200
      TabIndex        =   2
      Top             =   2520
      Width           =   2895
   End
   Begin VB.ListBox lstVarFirst 
      Height          =   420
      Left            =   4200
      TabIndex        =   1
      Top             =   1680
      Width           =   2895
   End
   Begin VB.ListBox lstVarSource 
      Height          =   2040
      Left            =   480
      TabIndex        =   0
      Top             =   1560
      Width           =   2655
   End
   Begin VB.Frame Frame2 
      Caption         =   "变量设置"
      Height          =   3015
      Left            =   240
      TabIndex        =   8
      Top             =   840
      Width           =   7215
      Begin VB.CommandButton cmdYes 
         Caption         =   "确  定"
         Height          =   375
         Left            =   5640
         TabIndex        =   10
         Top             =   2400
         Width           =   1095
      End
      Begin VB.CommandButton cmdReset 
         Caption         =   "重  设"
         Height          =   375
         Left            =   4080
         TabIndex        =   9
         Top             =   2400
         Width           =   1095
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         Caption         =   "变量二(纵轴)"
         Height          =   180
         Left            =   3960
         TabIndex        =   13
         Top             =   1320
         Width           =   1080
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "变量一(横轴)"
         Height          =   180
         Left            =   3960
         TabIndex        =   12
         Top             =   480
         Width           =   1080
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "源变量列表"
         Height          =   180
         Left            =   360
         TabIndex        =   11
         Top             =   360
         Width           =   900
      End
   End
End
Attribute VB_Name = "frmSpssDraw"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const strFileAndVariablesFirst As String = "请先打开数据文件，选择要分析的变量，并单击“确定”按钮。"
Const strFileChanged As String = "数据文件已经改变，要生成当前数据的交互图请首先输入变量，并单击“确定”按钮。"
Const strFileNotOpenOrNull As String = "请打开数据文件，或者您打开的数据文件为空文件。"
Const strVariableFirst As String = "请输入要分析的变量。"
Const strVariableChanged As String = "变量已经改变，要生成当前变量数据的交互图请首先输入变量，并单击“确定”按钮。"
Const strVarNotEnough As String = "变量个数不够，至少需要两个变量。"

Dim objSpssApp As Object
Dim objOutputDoc As Object
Dim objSPSSInfo As Object
Dim objDataDoc As Object
Dim objDocuments As Object
Dim objOutputItems As Object
Dim objOutputItem As Object
Dim objIGraph As Object
Dim strListOfVars() As String
Dim strSelVar() As String
Dim strSelVar2() As String
Dim strNotSelVar() As String
Dim bolSelected() As Integer
Dim intArrayIndex() As Integer
Dim bolDrawOrNot As Boolean
Dim bolFileChanged As Boolean
Dim bolVariableChanged As Boolean
Dim strVarFirst As String
Dim strVarSecond As String
Dim intListCountSource As Integer
Dim intListCountFirst As Integer
Dim intListCountSecond As Integer

Private Sub cmdDrawBar_Click()
  With IGBar1
    .strVarX = lstVarFirst.List(0)
    .strVarY = lstVarSecond.List(0)
  End With
  Call IGBar1.DrawIGraphBar(IGBar1.strVarX, IGBar1.strVarY)
End Sub



Private Sub cmdExit_Click()
  '将SPSS应用设置为Nothing
  Set objSpssApp = Nothing
  '卸载窗体
  Unload Me
End Sub

Private Sub cmdOpen_Click()
  Dim strFileName1 As String
  Dim strFileName2 As String
  
  CommonDialog1.CancelError = True
  On Error GoTo ErrHandler
  '设置过滤器
  CommonDialog1.Filter = "(*.sav)|*.sav"
  '指定缺省的过滤器
  CommonDialog1.FilterIndex = 1
  '显示“打开”对话框
  CommonDialog1.ShowOpen
  
  strFileName1 = Text1.Text
  Text1.Text = ""
  Text1.Text = Text1.Text & CommonDialog1.FileName
  Text1.Enabled = False
  
  strFileName2 = CommonDialog1.FileName
  '根据列表框中的内容决定移动按钮上标题的显示方式
  If (strFileName1 <> "") And (strFileName1 <> strFileName2) Then
    bolFileChanged = True
    cmdMove1.Enabled = True
    cmdMove2.Enabled = True
    cmdMove1.Caption = ">>"
    cmdMove2.Caption = ">>"
  End If
  
  '在数据编辑器中打开指定文件名的数据，数据编辑器不可见
  Set objDataDoc = objSpssApp.OpenDataDoc(CommonDialog1.FileName)
  objDataDoc.Visible = False
  
  '获取SPSS信息
  Set objSPSSInfo = objSpssApp.SpssInfo
  
  '获取变量
  Call GetVariables
  
  '如果数据文件中变量个数小于2，则不够分析
  If lstVarSource.ListCount < 2 Then
    MsgBox (strVarNotEnough)
    Exit Sub
  End If
  
ErrHandler:
  '如果用户单击“取消”按钮
  Exit Sub
  
End Sub
Sub GetVariables()
  Dim intNumVariables As Integer
  Dim intNumNotSel As Integer
  Dim intI As Integer
  
  '变量个数
  intNumVariables = objSPSSInfo.NumVariables - 1
  
  '定义动态数组
  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 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