opcmodule.vb

来自「OPCserver OPCserver.rar」· VB 代码 · 共 208 行

Option Strict Off
Option Explicit On
Module OPCModule
	
	'register
	'用GUIDGEN工具生成GUID的字符串
	'{5682D6F5-7730-4000-9D0D-3B2E8CD172CB}
	Public Const lpCLSID As String = "{5682D6F5-7730-4000-9D0D-3B2E8CD172CB}"
	Public Const lpOPCProgID As String = "TLSvrRDK.OPCTOOLKIT.2.VB"
	Public Const lpOPCDescr As String = "Tuo Lin RDK by VB6"
	
	Public Structure Tag
		Dim m_sTagName As String '//tagname
		Dim m_sDescr As String '//Description
		Dim m_hHWND As Integer '//Handle
		Dim m_vType As VariantType '//type
		Dim m_lQuality As Short '//Quality
		Dim m_ft As FILETIME '   //timestamp
		Dim m_vValue As Object '  //value
	End Structure
	
	Public Const MaxCounts As Short = 1000
	
	Public TagList(MaxCounts) As Tag
	
	'UPGRADE_WARNING: 结构 FILETIME 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"”
	Public Declare Sub GetSystemTimeAsFileTime Lib "kernel32" (ByRef lpSystemTimeAsFileTime As FILETIME)
	
	'UPGRADE_WARNING: 结构 SYSTEMTIME 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"”
	Public Declare Sub GetLocalTime Lib "kernel32" (ByRef lpSystemTime As SYSTEMTIME)
	'UPGRADE_WARNING: 结构 SYSTEMTIME 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"”
	'UPGRADE_WARNING: 结构 FILETIME 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"”
	Public Declare Function FileTimeToSystemTime Lib "kernel32" (ByRef lpFileTime As FILETIME, ByRef lpSystemTime As SYSTEMTIME) As Integer
	'UPGRADE_WARNING: 结构 FILETIME 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"”
	'UPGRADE_WARNING: 结构 SYSTEMTIME 可能要求封送处理属性作为此声明语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"”
	Public Declare Function SystemTimeToFileTime Lib "kernel32" (ByRef lpSystemTime As SYSTEMTIME, ByRef lpFileTime As FILETIME) As Integer
	
	
	Function GetAppPath() As String
		Dim sAppPath As String
		sAppPath = VB6.GetPath
		If Right(sAppPath, 1) <> "\" Then
			sAppPath = sAppPath & "\"
		End If
		GetAppPath = sAppPath
	End Function
	Function GetAppExeName() As String
		Dim sAppExeName As String
		sAppExeName = VB6.GetExeName()
		sAppExeName = sAppExeName & ".exe"
		GetAppExeName = sAppExeName
	End Function
	Function OnRegister() As Boolean
		'//注册OPC服务器
		Dim bResult As Boolean
		If (TL_RegistryS(lpCLSID, lpOPCProgID, lpOPCDescr, GetAppPath & GetAppExeName) > 0) Then
			bResult = True
			Call MsgBox("注册成功", 64)
		Else
			bResult = False
			Call MsgBox("注册失败", 48)
		End If
		OnRegister = bResult
	End Function
	Function OnUnRegister() As Boolean
		'//反注册OPC服务器
		Dim bResult As Boolean
		If (TL_UnregisterS(lpCLSID, lpOPCProgID) > 0) Then
			bResult = True
			Call MsgBox("反注册成功", 64)
		Else
			bResult = False
			Call MsgBox("反注册失败", 48)
		End If
		OnUnRegister = bResult
	End Function
	Function OnInitOpcServer() As Boolean
		'    //初始化OPC Server
		Dim bResult As Boolean
		bResult = TL_SetupRegCode("TUOLIN20030713NOTAGCOUNTS")
		bResult = TL_InitOpcServerS(lpCLSID, 500)
        '//设定服务器的分隔符
        TL_SetQualifier(Asc("."))
		'UPGRADE_WARNING: 为 AddressOf WriteNotifyCallback 添加委托 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1048"”
        Call TL_EnableWriteNotification(AddressOf WriteNotifyCallback)
		'UPGRADE_WARNING: 为 AddressOf DisconnectProc 添加委托 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1048"”
        Call TL_EnableDisconnectNotification(AddressOf DisconnectProc)
		'UPGRADE_WARNING: 为 AddressOf DeviceReadProc 添加委托 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1048"”
        Call TL_EnableDeviceRead(AddressOf DeviceReadProc)
		
		OnInitOpcServer = bResult
		
	End Function
	
	Sub OnUnInitOpcServer()
		'//结束OPC Server
		Call TL_UnInitOpcServer()
	End Sub
	
	Sub OnAddItem()
		'建立点数组
		Dim i As Short
		For i = 1 To MaxCounts
			TagList(i).m_sTagName = "TAG" & VB6.Format(i, "0000")
			TagList(i).m_sDescr = "m_sDescr tag" & VB6.Format(i, "0000")
			TagList(i).m_hHWND = -1
			GetSystemTimeAsFileTime(TagList(i).m_ft)
			TagList(i).m_lQuality = OPC_QUALITY_BAD
			
			Select Case i Mod 4
				Case 0
					TagList(i).m_vType = VariantType.Boolean
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = False
				Case 1
					TagList(i).m_vType = VariantType.Short
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = 0
				Case 2
					TagList(i).m_vType = VariantType.Single
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = 0#
				Case 3
					TagList(i).m_vType = VariantType.String
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = "vbString"
				Case Else
					
			End Select
		Next 
		'加入opc server
		For i = 1 To MaxCounts
			TagList(i).m_hHWND = TL_CreateTag(TagList(i).m_sTagName, TagList(i).m_vValue, TagList(i).m_lQuality, True)
			'//pTagName->m_sDescr
			'// 101 详见DA 2.04 中的 41页 4.4.6 节
			Call TL_SetTagProperties(TagList(i).m_hHWND, 101, "Item Description", TagList(i).m_sDescr)
			
		Next 
		Call MsgBox("additem end", 64)
	End Sub
	
	Sub OnDeleteItem()
		Dim i As Short
		'删除所有点opc server
		For i = 1 To MaxCounts
			TL_RemoveTag(TagList(i).m_hHWND)
		Next 
		Call MsgBox("delete item end", 64)
		
	End Sub
	Sub OnUpdateData()
		Dim i As Short
		Dim sStr As String

		'修改所有点opc server
        For i = 1 To MaxCounts
            sStr = Space(1024)
            'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
            sStr = "Name :" & TagList(i).m_sTagName & " ,Quality:= " & Str(TagList(i).m_lQuality) & ", Value =" & TagList(i).m_vValue
            If i = 1 Then
                FrmMain.DefInstance.Text1.Text = "名称  , 通讯质量，值"
            End If
            If i < 100 Then
                FrmMain.DefInstance.Text1.Text = FrmMain.DefInstance.Text1.Text & Chr(13) & Chr(10) & sStr
            End If
            Call TL_UpdateTag(TagList(i).m_hHWND, TagList(i).m_vValue, TagList(i).m_lQuality)
        Next
	End Sub
	
	Sub OnRandomData()
		'产生随机数据
		Dim i As Short
		Dim iRand As Single
		For i = 1 To MaxCounts
			iRand = Rnd(1) * 1000
			'If (iRand > 400) Then
			'    TagList(i).m_lQuality = OPC_QUALITY_UNCERTAIN
			'    If (iRand > 800) Then
			'    TagList(i).m_lQuality = OPC_QUALITY_GOOD
			'    End If
			'    Else
			'    TagList(i).m_lQuality = OPC_QUALITY_BAD
			'End If
			TagList(i).m_lQuality = OPC_QUALITY_GOOD
			Select Case i Mod 4
				Case 0
					If (iRand > 500) Then
						'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
						TagList(i).m_vValue = False
					Else
						'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
						TagList(i).m_vValue = True
					End If
				Case 1
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = CShort(iRand)
				Case 2
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = iRand
				Case 3
					'UPGRADE_WARNING: 未能解析对象 TagList().m_vValue 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"”
					TagList(i).m_vValue = VB6.Format(iRand, "###0.00")
				Case Else
			End Select
		Next 
		System.Windows.Forms.Application.DoEvents()
	End Sub
End Module