igscoplot.ctl

SPSS的实战介绍

VERSION 5.00
Begin VB.UserControl IGBar 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.PictureBox Picture1 
      Height          =   2895
      Left            =   480
      ScaleHeight     =   2835
      ScaleWidth      =   3915
      TabIndex        =   0
      Top             =   360
      Width           =   3975
      Begin VB.Image ImgDraw 
         Height          =   2895
         Left            =   0
         Top             =   0
         Width           =   3975
      End
   End
End
Attribute VB_Name = "IGBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'缺省属性值:
Const m_def_BackColor = 0
Const m_def_ForeColor = 0
Const m_def_Enabled = 0
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
Const m_def_strVarX = "0"
Const m_def_strVarY = "0"
'属性变量:
Dim m_BackColor As Long
Dim m_ForeColor As Long
Dim m_Enabled As Boolean
Dim m_Font As Font
Dim m_BackStyle As Integer
Dim m_BorderStyle As Integer
Dim m_strVarX As String
Dim m_strVarY 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
'事件声明:
Event Click()
Attribute Click.VB_Description = "当用户在一个对象上按下并释放鼠标按钮时发生。"
Event DblClick()
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_Description = "当用户在拥有焦点的对象上按下任意键时发生。"
Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "当用户按下和释放 ANSI 键时发生。"
Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "当用户在拥有焦点的对象上释放键时发生。"
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_Description = "当用户在拥有焦点的对象上按下鼠标按钮时发生。"
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_Description = "当用户在拥有焦点的对象上释放鼠标发生。"



'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get BackColor() As Long
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = m_BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As Long)
    m_BackColor = New_BackColor
    PropertyChanged "BackColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get ForeColor() As Long
Attribute ForeColor.VB_Description = "返回/设置对象中文本和图形的前景色。"
    ForeColor = m_ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As Long)
    m_ForeColor = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置一个值，决定一个对象是否响应用户生成事件。"
    Enabled = m_Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=6,0,0,0
Public Property Get Font() As Font
Attribute Font.VB_Description = "返回一个 Font 对象。"
Attribute Font.VB_UserMemId = -512
    Set Font = m_Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set m_Font = New_Font
    PropertyChanged "Font"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "指出 Label 或 Shape 的背景样式是透明的还是不透明的。"
    BackStyle = m_BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    m_BackStyle = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "返回/设置对象的边框样式。"
    BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    m_BorderStyle = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=5
Public Sub Refresh()
Attribute Refresh.VB_Description = "强制完全重画一个对象。"
     
End Sub

'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,0
Public Property Get strVarX() As String
    strVarX = m_strVarX
End Property

Public Property Let strVarX(ByVal New_strVarX As String)
    m_strVarX = New_strVarX
    PropertyChanged "strVarX"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,0
Public Property Get strVarY() As String
    strVarY = m_strVarY
End Property

Public Property Let strVarY(ByVal New_strVarY As String)
    m_strVarY = New_strVarY
    PropertyChanged "strVarY"
End Property

Private Sub UserControl_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

End Sub

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_BackColor = m_def_BackColor
    m_ForeColor = m_def_ForeColor
    m_Enabled = m_def_Enabled
    Set m_Font = Ambient.Font
    m_BackStyle = m_def_BackStyle
    m_BorderStyle = m_def_BorderStyle
    m_strVarX = m_def_strVarX
    m_strVarY = m_def_strVarY
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
    m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    Set m_Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    m_strVarX = PropBag.ReadProperty("strVarX", m_def_strVarX)
    m_strVarY = PropBag.ReadProperty("strVarY", m_def_strVarY)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
    Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("strVarX", m_strVarX, m_def_strVarX)
    Call PropBag.WriteProperty("strVarY", m_strVarY, m_def_strVarY)
End Sub

Sub DrawIGraphBar(strVarX As String, strVarY As String)
  '创建新的输出浏览器窗口，不可见
  Set objOutputDoc = objSpssApp.NewOutputDoc
  objOutputDoc.Visible = False


    '利用Syntax命令绘交互条图
    Dim strCommand As String
    strCommand = strCommand & "IGRAPH "
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/VIEWNAME='Bar Chart'"
    strCommand = strCommand & "/X1 = VAR("
    strCommand = strCommand & strVarX
    strCommand = strCommand & ")"
    strCommand = strCommand & vbCrLf
    strCommand = strCommand & "/Y = VAR("
    strCommand = strCommand & strVarY
    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 & strVarX
    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
    
      '在输出浏览器中获取交互图对象
  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
  
    Dim strFilePath As String
    strFilePath = App.Path & "\IGraph0.bmp"
  With ImgDraw
    .Stretch = True
    .Visible = True
    .Picture = LoadPicture(strFilePath)
  End With

End Sub