Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
792 lines (685 sloc) 20.8 KB
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form fmMain
Caption = "OPCSAVEDATA-SubVersion Application By Mister.T"
ClientHeight = 8070
ClientLeft = 60
ClientTop = 345
ClientWidth = 14655
BeginProperty Font
Name = "Tahoma"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "Form1"
ScaleHeight = 8070
ScaleWidth = 14655
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command2
Caption = "Read"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 12720
TabIndex = 10
Top = 3480
Width = 975
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 9
Top = 7695
Width = 14655
_ExtentX = 25850
_ExtentY = 661
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 3
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 20188
Text = "Status"
TextSave = "Status"
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Style = 6
AutoSize = 2
TextSave = "7/22/2011"
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 2
EndProperty
EndProperty
End
Begin MSComctlLib.ListView LvListView
Height = 5895
Left = 960
TabIndex = 7
Top = 840
Width = 11175
_ExtentX = 19711
_ExtentY = 10398
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.CommandButton Command1
Caption = "导入变量"
Enabled = 0 'False
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 12720
TabIndex = 6
Top = 1440
Width = 975
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 960
TabIndex = 4
Text = "Text1"
Top = 6840
Width = 2295
End
Begin VB.CheckBox DataChgChk
Caption = "使用订阅数据采取"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 12360
TabIndex = 3
Top = 840
Value = 1 'Checked
Width = 1815
End
Begin VB.Timer tmUpdate
Left = 13440
Top = 4680
End
Begin VB.CommandButton btnAddItem
Caption = "读取"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 12720
TabIndex = 2
Top = 2400
Width = 975
End
Begin VB.CommandButton btnQuit
Caption = "退出"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 12720
TabIndex = 1
Top = 2880
Width = 975
End
Begin VB.CommandButton btnConnect
Caption = "连接"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 12720
TabIndex = 0
Top = 1920
Width = 975
End
Begin VB.Frame OPC
Caption = "OPC数据采集"
Height = 7335
Left = 360
TabIndex = 8
Top = 360
Width = 14055
End
Begin VB.Label Label1
Caption = "Label1"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 5280
TabIndex = 5
Top = 6600
Width = 2055
End
End
Attribute VB_Name = "fmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 1
Option Explicit
' OPC对象的声明
Dim WithEvents objserver As OPCServer
Attribute objserver.VB_VarHelpID = -1
Dim objGroups As OPCGroups
Dim WithEvents objtestgrp As OPCGroup '事件的对应
Attribute objtestgrp.VB_VarHelpID = -1
Dim objItems As OPCItems
Dim LServerHandles() As Long
Dim x As Integer
Dim y As Integer
Dim mon As Integer
Dim d As Integer
Dim h As Integer
Dim m As Integer
Dim s As Integer
Dim ss As Boolean
Dim lTransID_Rd As Long
Dim lCancelID_Rd As Long
Dim lTransID_Wt As Long
Dim lCancelID_Wt As Long
Sub Connect(strProgID As String, Optional strNode As String)
If objserver Is Nothing Then
' 建立一个OPC服务器对象
Set objserver = New OPCServer
End If
If objserver.ServerState = OPCDisconnected Then
' 连接OPC服务器
objserver.Connect strProgID, strNode
End If
If objGroups Is Nothing Then
' 建立一个OPC组集合
Set objGroups = objserver.OPCGroups
End If
If objtestgrp Is Nothing Then
' 添加一个OPC组
Set objtestgrp = objGroups.Add("TestGrp")
End If
End Sub
Sub Disconnect()
Dim lErrors() As Long
If Not objItems Is Nothing Then
If objItems.Count > 0 Then
' 清除OPC项
objItems.Remove 114, LServerHandles, lErrors
End If
Set objItems = Nothing
End If
If Not objtestgrp Is Nothing Then
' 清除OPC组
objGroups.Remove "TestGrp"
Set objtestgrp = Nothing
End If
If Not objGroups Is Nothing Then
Set objGroups = Nothing
End If
If Not objserver Is Nothing Then
If objserver.ServerState <> OPCDisconnected Then
' 断开OPC服务器.
objserver.Disconnect
End If
Set objserver = Nothing
End If
End Sub
Sub AddItem()
Dim strItemIDs(114) As String
Dim lClientHandles(114) As Long
Dim lErrors() As Long
Dim i As Integer
Dim ExcelApp As Excel.Application
Dim ExcelBook As Excel.Workbook
Dim ExcelSheet As Excel.Worksheet
Dim Strfilename As String
If objtestgrp Is Nothing Then
Exit Sub
End If
If Not objItems Is Nothing Then
If objItems.Count > 0 Then
Exit Sub
End If
End If
' 设置组活动状态
If DataChgChk.Value = vbChecked Then
objtestgrp.IsActive = True
Else
objtestgrp.IsActive = False
End If
' 启动组非同期通知
objtestgrp.IsSubscribed = True
' 建立OPC项集合
Set objItems = objtestgrp.OPCItems
'查询数据库,得到TAG名
Dim TagName As String, MyTable As String
TagName = "TAGNAME"
MyTable = "TAG"
Dim testg As Variant
' testg = ReadData(MyTable, Tagname)
For i = 1 To LvListView.ListItems.Count
lClientHandles(i) = i
strItemIDs(i) = LvListView.ListItems(i).SubItems(1)
Next i
' I = 1
' Do While Not rs.EOF
' strItemIDs(I) = rs("TAGNAME")
' lClientHandles(I) = I
' I = I + 1
' rs.MoveNext
'Loop
'弹出提示信息
' MsgBox "XXXXXXXXXX", vbInformation + vbOKOnly
'关闭数据集和与数据库的连接,并释放变量
StatusBar1.Panels(1).Text = " 数据加载成功"
' 生成从TAG1到TAG8的项标识符
' For I = 1 To 5
' strItemIDs(I) = "Simulation Items.Integer.Int_0" & I
' lClientHandles(I) = I
' Next
' For I = 6 To 8
' strItemIDs(I) = "Simulation Items.Real.Real_0" & I - 5
' lClientHandles(I) = I
' Next
' 添加OPC项
Call objItems.AddItems(114, strItemIDs, _
lClientHandles, LServerHandles, lErrors)
' ss = False
'
'Label1:
'Call AsyncRead
'Dim Savetime As Double
'timeBeginPeriod 1
'Savetime = timeGetTime
'While timeGetTime < Savetime + 1000
' If ss = True Then
' timeEndPeriod 1
' Call Disconnect
'' Set OPCServer = Nothing
' Exit Sub
' End If
'DoEvents
'Wend
'GoTo Label1
End Sub
Sub AsyncRead()
Dim lErrors() As Long
StatusBar1.Panels(1).Text = "Data Reading..."
If objtestgrp Is Nothing Then
Exit Sub
End If
If objtestgrp.OPCItems.Count > 0 Then
' 非同期读取
lTransID_Rd = lTransID_Rd + 1
objtestgrp.AsyncRead 114, LServerHandles, _
lErrors, lTransID_Rd, lCancelID_Rd
End If
End Sub
Sub AsyncWrite(nIndex As Integer, ByRef vtItemValues() As Variant, _
ByRef lErrors() As Long)
Dim lHandle(1) As Long
If objtestgrp Is Nothing Then
Exit Sub
End If
If objtestgrp.OPCItems.Count > 0 Then
lHandle(1) = LServerHandles(nIndex)
' 非同期写入
lTransID_Wt = lTransID_Wt + 1
objtestgrp.AsyncWrite 1, lHandle(), vtItemValues, _
lErrors, lTransID_Wt, lCancelID_Wt
End If
End Sub
Private Sub Command1_Click()
Dim i As Integer
Dim ExcelApp As Excel.Application
Dim ExcelBook As Excel.Workbook
Dim ExcelSheet As Excel.Worksheet
Dim Strfilename As String
Dim xxx(8) As Variant
Dim yyy(8) As Variant
Strfilename = "D:\My Documents\Desktop\ASYNC.xls"
Set ExcelApp = New Excel.Application
Set ExcelBook = ExcelApp.Workbooks.Open(Strfilename)
Set ExcelSheet = ExcelBook.Sheets(1)
ExcelApp.Visible = False
With Worksheets("Sheet1")
For i = 1 To 8
' 从工作表中得到TAG1到TAG8的项标识符
xxx(i) = .Cells(i + 1, 3).Text
yyy(i) = .Cells(i + 1, 2).Text
Next i
' .Range("A2:i65").ClearContents
End With
ExcelApp.Quit
Set ExcelBook = Nothing
Set ExcelSheet = Nothing
Set ExcelApp = Nothing
'连接ACCESS
Dim MyData As String, MyTable As String
Dim Cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim x As Integer
Dim myArray As Variant
myArray = Array("00013", "国际贸易部", "何伟立", "男", "项目经理", _
"工程师", "硕士", "河北省", #3/28/1982#, 24, #8/16/2006#, 0, #8/16/2006#, 0)
MyData = "D:\My Documents\Desktop\OPC1.mdb"
MyTable = "职工基本信息"
'建立与数据库的连接
Set Cnn = New ADODB.Connection
With Cnn
.Provider = "microsoft.jet.oledb.4.0"
.Open MyData
End With
'查询数据表
Set rs = New ADODB.Recordset
rs.Open "TAG", Cnn, 1, 3
'添加记录
With rs
For x = 1 To 8
.AddNew '添加各个字段的数据
rs("TAGName") = xxx(x)
rs("TAGDIS") = yyy(x)
.Update
Next x
'更新数据表
End With
'弹出提示信息
MsgBox "已经成功将新职工的数据添加到数据库中!", vbInformation + vbOKOnly
'关闭数据集和与数据库的连接,并释放变量
rs.Close
Cnn.Close
Set rs = Nothing
Set Cnn = Nothing
Dim mycat As New adox.Catalog '定义ADOX的catalog对象变量
Dim mytbl As New Table '定义table对象变量
'设置数据库名称(包括完整路径)
'设置要创建的数据表名称
MyTable = "TAGVALUE"
'建立与数据库的连接
mycat.ActiveConnection = "provider=microsoft.jet.oledb.4.0;" & "data source=" & MyData
'删除数据库中已经存在的数据表
'mycat.Tables.Delete mytable
'创建数据表,并添加字段
With mytbl
.Name = MyTable
.Columns.Append "学号", adVarWChar, 10
For x = 1 To 10
.Columns.Append yyy(x), adDouble
Next x
' .Columns.Append "姓名", adVarWChar, 6
' .Columns.Append "性别", adVarWChar, 1
' .Columns.Append "班级", adVarWChar, 10
' .Columns.Append "数学", adDouble
' .Columns.Append "语文", adSingle
' .Columns.Append "物理", adSingle
' .Columns.Append "化学", adSingle
' .Columns.Append "英语", adSingle
' .Columns.Append "DATE", adDBTimeStamp
End With
'将创建的数据表添加到ADOX的tables集合中
mycat.Tables.Append mytbl
'释放变量
Set mycat = Nothing
Set mytbl = Nothing
'弹出信息
MsgBox "数据表<" & MyTable & ">创建成功!", vbInformation, "创建数据表"
End Sub
Private Sub Command2_Click()
Call AsyncRead
End Sub
Private Sub DataChgChk_Click()
If DataChgChk.Value = vbChecked Then
tmUpdate.Enabled = False
If Not objtestgrp Is Nothing Then
objtestgrp.IsActive = True
End If
Else
tmUpdate.Enabled = True
If Not objtestgrp Is Nothing Then
objtestgrp.IsActive = False
End If
End If
End Sub
Private Sub Form_Load()
' 初始化全局变量
DataChgChk.Value = vbUnchecked
tmUpdate.Enabled = True
' tmUpdate.Enabled = False
tmUpdate.Interval = 1000
lTransID_Rd = 0
lTransID_Wt = 0
LvListView.ColumnHeaders.Add 1, , "序号", LvListView.Width / 4
LvListView.ColumnHeaders.Add 2, , "标签变量", LvListView.Width / 4
LvListView.ColumnHeaders.Add 3, , "标签名称", LvListView.Width / 4
LvListView.ColumnHeaders.Add 4, , "标签值", LvListView.Width / 4
LvListView.ColumnHeaders.Add 5, , "TEST", LvListView.Width / 5
Dim TagName As String, MyTable As String
TagName = "TAGNAME"
MyTable = "TAG"
Dim testg() As Report_Data
ReDim testg(114) As Report_Data
testg = ReadData(MyTable, TagName)
For i = LBound(testg) To UBound(testg)
'For i = 1 To 8
Set itx = LvListView.ListItems.Add(, , i)
itx.SubItems(1) = testg(i).TagName
itx.SubItems(2) = testg(i).TagDIS
Next i
' Set itx = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
' 调用Disconnect子程序
Call Disconnect
End Sub
Private Sub btnConnect_Click()
'调用Connect子程序
' Call Connect("DSxPOpcSimulator.TSxOpcSimulator.1")
' Call Connect("DSxPOpcSimulator.TSxOpcSimulator.1", "127.0.0.1")
Call Connect("Freelance2000OPCServer.49.1", "172.16.1.48")
End Sub
Private Sub btnAddItem_Click()
' 调用AddItem子程序
Call AddItem
End Sub
Private Sub btnQuit_Click()
' 卸载窗体
ss = True
Unload fmMain
End Sub
Private Sub tmUpdate_Timer()
' 非同期读取
Call AsyncRead
End Sub
Private Sub objtestgrp_AsyncReadComplete( _
ByVal TransactionID As Long, ByVal NumItems As Long, _
ClientHandles() As Long, ItemValues() As Variant, _
Qualities() As Long, TimeStamps() As Date, Errors() As Long)
' Dim strBuf As String
' Dim nWidth As Integer
' Dim nHeight As Integer
' Dim nDrawHeight As Integer
' Dim sglScale As Single
' Dim i As Integer
' Dim Index As Integer
'Dim x1 As Integer
' For x1 = 1 To UBound(ClientHandles)
' LvListView.ListItems(x1).SubItems(4) = ClientHandles(x1)
'
' Next x1
For i = 1 To UBound(ItemValues)
' Set itx = LvListView.ListItems(i)
' itx.SubItems(3) = ItemValues(i)
' Next i
LvListView.ListItems(i).SubItems(3) = ItemValues(i)
Next i
StatusBar1.Panels(1).Text = "Read Complete......"
'
'
' ReDim LastData(CInt(UBound(ItemValues))) As Variant
Text1.Text = Time
Label1.Caption = s
StatusBar1.Panels(3).Text = Time
'
s = Second(Time)
m = Minute(Time)
h = Hour(Time)
If (s = 0 And m = 0 And h = 8) Or (h = 0 And m = 0 And s = 0) Or (h = 16 And m = 0 And s = 0) Then
Dim MyData As String
Dim MyTable(4) As String
Dim xx As Integer
Dim xxx(50) As Variant
Dim myArray As Variant
Dim j As Integer
Dim DB_ep() As Variant
Dim ModNub As Date
ModNub = Now
xx = 8
MyData = "database\OPC1.mdb"
MyTable(1) = "立磨系统"
MyTable(2) = "窑系统"
MyTable(3) = "水泥A磨"
MyTable(4) = "水泥B磨"
DB_ep = CheckData(MyTable(1), h)
Call SaveData(MyTable(1), 1, 19, -3, DB_ep, ModNub)
DB_ep = CheckData(MyTable(2), h)
Call SaveData(MyTable(2), 22, 57, 18, DB_ep, ModNub)
DB_ep = CheckData(MyTable(3), h)
Call SaveData(MyTable(3), 60, 84, 56, DB_ep, ModNub)
DB_ep = CheckData(MyTable(4), h)
Call SaveData(MyTable(4), 87, 111, 83, DB_ep, ModNub)
'Call SaveData(MyTable, 1, 21, -1,h)
'Call SaveData("tagvalue1", 22, 59, 20,h)
'Call SaveData("", 60, 86, 58,h)
'Call SaveData("", 87, 113, 85,h)
'Call SaveData("tagvalue1", 9, 16, 8, DB_ep, 16)
End If
End Sub
Private Sub objtestgrp_AsyncWriteComplete( _
ByVal TransactionID As Long, ByVal NumItems As Long, _
ClientHandles() As Long, Errors() As Long)
End Sub
Private Sub objTestGrp_DataChange( _
ByVal TransactionID As Long, ByVal NumItems As Long, _
ClientHandles() As Long, ItemValues() As Variant, _
Qualities() As Long, TimeStamps() As Date)
Dim strBuf As String
Dim nWidth As Integer
Dim nHeight As Integer
Dim nDrawHeight As Integer
Dim sglScale As Single
Dim x1 As Integer
Dim x2 As Integer
Dim Index As Integer
' ReDim LastData(CInt(UBound(ItemValues))) As Variant
Text1.Text = Time
Label1.Caption = s
StatusBar1.Panels(3).Text = Time
' x = x + 1
s = Second(Time)
m = Minute(Time)
h = Hour(Time)
' For x1 = 1 To UBound(ClientHandles)
' x2 = CInt(ClientHandles(x1))
' LvListView.ListItems(x2).SubItems(4) = ClientHandles(x1)
'
' Next x1
For i = 1 To UBound(ItemValues)
x2 = CInt(ClientHandles(i))
Set itx = LvListView.ListItems(x2)
itx.SubItems(3) = ItemValues(i)
Next i
If (s = 0 And m = 0 And h = 8) Or (h = 0 And m = 0 And s = 0) Or (h = 16 And m = 0 And s = 0) Then
Dim MyData As String
Dim MyTable(4) As String
Dim xx As Integer
Dim xxx(50) As Variant
Dim myArray As Variant
Dim j As Integer
Dim DB_ep() As Variant
Dim ModNub As Date
ModNub = Now
xx = 8
MyData = "database\OPC1.mdb"
MyTable(1) = "立磨系统"
MyTable(2) = "窑系统"
MyTable(3) = "水泥A磨"
MyTable(4) = "水泥B磨"
DB_ep = CheckData(MyTable(1), h)
Call SaveData(MyTable(1), 1, 19, -3, DB_ep, ModNub)
DB_ep = CheckData(MyTable(2), h)
Call SaveData(MyTable(2), 22, 57, 18, DB_ep, ModNub)
DB_ep = CheckData(MyTable(3), h)
Call SaveData(MyTable(3), 60, 84, 56, DB_ep, ModNub)
DB_ep = CheckData(MyTable(4), h)
Call SaveData(MyTable(4), 87, 111, 83, DB_ep, ModNub)
'Call SaveData(MyTable, 1, 21, -1,h)
'Call SaveData("tagvalue1", 22, 59, 20,h)
'Call SaveData("", 60, 86, 58,h)
'Call SaveData("", 87, 113, 85,h)
'Call SaveData("tagvalue1", 9, 16, 8, DB_ep, 16)
End If
End Sub