frmrealcurve.frm

来自「vb曲线功能,详细的代码分析了如何绘制动态曲线」· FRM 代码 · 共 292 行

VERSION 5.00
Object = "{8996B0A4-D7BE-101B-8650-00AA003A5593}#4.0#0"; "Cfx4032.ocx"
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form frmRealCurve 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "实时曲线浏览"
   ClientHeight    =   6525
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   12015
   Icon            =   "frmRealCurve.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6525
   ScaleWidth      =   12015
   StartUpPosition =   1  '所有者中心
   Begin TabDlg.SSTab SSTab1 
      Height          =   6530
      Left            =   0
      TabIndex        =   2
      Top             =   0
      Width           =   12015
      _ExtentX        =   21193
      _ExtentY        =   11509
      _Version        =   393216
      Tabs            =   1
      TabsPerRow      =   1
      TabHeight       =   520
      TabCaption(0)   =   "Tab 0"
      TabPicture(0)   =   "frmRealCurve.frx":0442
      Tab(0).ControlEnabled=   -1  'True
      Tab(0).Control(0)=   "Timer1"
      Tab(0).Control(0).Enabled=   0   'False
      Tab(0).Control(1)=   "Frame1"
      Tab(0).Control(1).Enabled=   0   'False
      Tab(0).Control(2)=   "ChartFX1"
      Tab(0).Control(2).Enabled=   0   'False
      Tab(0).ControlCount=   3
      Begin ChartfxLibCtl.ChartFX ChartFX1 
         Height          =   5535
         Left            =   120
         TabIndex        =   6
         Top             =   840
         Width           =   11775
         _cx             =   4280610
         _cy             =   4269603
         Build           =   21
         TypeMask        =   109576193
         Style           =   -9437191
         DblClk          =   2
         RigClk          =   4
         CylSides        =   32
         MarkerShape     =   2
         MarkerSize      =   1
         RGBBk           =   16777231
         RGB2DBk         =   16777219
         nColors         =   16
         Colors          =   "frmRealCurve.frx":045E
         nSer            =   1
         NumSer          =   1
         _Data_          =   "frmRealCurve.frx":04FE
      End
      Begin VB.Frame Frame1 
         Caption         =   "通道号选择"
         Height          =   615
         Left            =   2520
         TabIndex        =   3
         Top             =   100
         Width           =   6735
         Begin VB.ComboBox CmbGW 
            Height          =   300
            Left            =   1140
            Style           =   2  'Dropdown List
            TabIndex        =   0
            Top             =   195
            Width           =   1815
         End
         Begin VB.ComboBox CmbTDH 
            Height          =   300
            Left            =   4560
            Style           =   2  'Dropdown List
            TabIndex        =   1
            Top             =   195
            Width           =   1815
         End
         Begin VB.Label Label2 
            BackStyle       =   0  'Transparent
            Caption         =   "通道号:"
            Height          =   255
            Left            =   3885
            TabIndex        =   5
            Top             =   240
            Width           =   735
         End
         Begin VB.Label Label1 
            BackStyle       =   0  'Transparent
            Caption         =   "委托单号:"
            Height          =   255
            Left            =   270
            TabIndex        =   4
            Top             =   240
            Width           =   975
         End
      End
      Begin VB.Timer Timer1 
         Left            =   360
         Top             =   120
      End
   End
End
Attribute VB_Name = "frmRealCurve"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
    Dim Conn As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim Mysql As String
    Dim CntNum As Integer '总循环次数
    Dim CntRefresh As Integer
    
'    Dim MaxVal As Double
'    Dim MinVal As Double
    Dim CH_Index As String
    

Private Sub CmbGW_Click()
   Dim Str_Box As String
   Dim Str_CH As String
   Dim Cnt As Integer
  
  On Error GoTo errCL
   Me.CmbTDH.Clear
   
   Set Rst = New ADODB.Recordset
   Rst.Open "select 通道号 from 通道设置 where 委托单号='" & Trim(Me.CmbGW.Text) & "' order by 通道号", Conn, adOpenStatic, adLockOptimistic
     
     If Rst.RecordCount > 0 Then
           Rst.MoveFirst
        Do While Not Rst.EOF
           Str_CH = CStr(Rst.Fields(0).Value)
           
           If Len(Str_CH) = 1 Then
              Str_CH = "0" & Str_CH
           End If
              
           Me.CmbTDH.AddItem "通道" & Str_CH
           Rst.MoveNext
        Loop
        
           Me.CmbTDH.ListIndex = 0
           
     End If
    
     Me.Timer1.Enabled = False
     
    Call CurveRefresh
    Me.Timer1.Enabled = True
Exit Sub
errCL:
  MsgBox Err.Description, vbExclamation, "警告"
End Sub

Private Sub CmbTDH_Click()
     Dim Cnt As Integer
     
     Me.Timer1.Enabled = False
     Call CurveRefresh '刷新曲线
     Me.Timer1.Enabled = True
End Sub

Private Sub Command1_Click()
  Unload Me
End Sub

Private Sub Form_Load()
    Dim I As Integer
         
  On Error GoTo errCL
  
     CH_Index = 0
     Me.Left = (Screen.Width - Me.Width) / 2
     Me.Top = (Screen.Height - Me.Height) / 2 + 150
     Me.ChartFX1.Axis(AXIS_X).Visible = False
     Me.ChartFX1.Axis(AXIS_X).Format = AF_DATETIME
     Me.ChartFX1.Series(0).Visible = False
          
     Me.ChartFX1.Axis(AXIS_X).GridStyle = CHART_DOT
     Me.ChartFX1.Axis(AXIS_Y).GridStyle = CHART_DOT
   '  KeepOnTop Me
     Call BasePara
     
      '数据库连接
     Set Conn = New ADODB.Connection
     Conn.CursorLocation = adUseClient
     Conn.Open "Provider=SQLOLEDB.1;Password=" & LocalPwd & ";Persist Security Info=True;User ID=" & LocalName & ";Initial Catalog=DBTestT"
     
     Me.CmbGW.Clear
     Set Rst = New ADODB.Recordset
     Rst.Open "select distinct 委托单号 from 通道设置", Conn, adOpenStatic, adLockOptimistic
     
     If Rst.RecordCount > 0 Then
          Rst.MoveFirst
          
        Do While Not Rst.EOF
           Me.CmbGW.AddItem Trim(Rst.Fields(0).Value)
           Rst.MoveNext
        Loop
           Me.CmbGW.ListIndex = 0
     End If

     CntRefresh = 0
     Me.Timer1.Enabled = False
     Me.Timer1.Interval = 4000
     Me.Timer1.Enabled = True
   Exit Sub
errCL:
    MsgBox Err.Description, vbInformation, "实时曲线浏览"
End Sub

Private Sub CurveRefresh()
  On Error GoTo errCL
   Dim CfxData As New CfxDataAdo
   Dim CntNo As Integer
   Dim I As Integer
   Dim Ch_No As String
   
   '初始化变量
   
   Mysql = ""
   Set Rst = Conn.OpenSchema(adSchemaTables, Array(Empty, Empty, "T" & Trim(Me.CmbGW.Text), "Table"))
        
  If Not Rst.EOF Then
         Me.ChartFX1.Axis(AXIS_X).Visible = True
         Me.ChartFX1.Series(0).Visible = True
         Set Rst = New ADODB.Recordset
         Mysql = "select top 300 collectdate,CH" & Right(Me.CmbTDH.Text, 2) & "T from T" & Trim(Me.CmbGW.Text) & " order by collectdate"
         Rst.Open Mysql, Conn, adOpenStatic, adLockOptimistic
         CfxData.ResultSet = Rst
         Me.ChartFX1.GetExternalData CfxData
  End If
        
Exit Sub
errCL:
 'MsgBox Err.Description, vbInformation, "信息提示"
  Err.Clear
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error GoTo errCL
    
    Timer1.Enabled = False
    If Rst.State = adStateOpen Then
      Rst.Close
    End If
    Set Rst = Nothing
    Clipboard.Clear

 Exit Sub
errCL:
   MsgBox Err.Description, vbExclamation, "警告"
   Set Rst = Nothing
End Sub

Private Sub SStab1_Click(PreviousTab As Integer)
  Call CurveRefresh
End Sub

Private Sub Timer1_Timer()
  On Error GoTo errCL
 
   CntRefresh = CntRefresh + 1
   If CntRefresh >= 150 Then
     Timer1.Enabled = False
     Unload Me
     Exit Sub
   End If
   
   Timer1.Enabled = False
   Call CurveRefresh
   Me.Timer1.Enabled = True
  
 Exit Sub
errCL:
  Err.Clear
  Me.Timer1.Enabled = True
End Sub