wincc VBS脚本配置

2021-01-08  本文已影响0人  心淡然如水

WIncc数据库链接脚本代码

Public strSQL
Public strConnectionString
Public objRecordset
Public objConnection
Public objCommand


Sub saveSatusWd(status,name)

Dim objConnection
Dim strConnectionString
Dim lngValue
Dim strSQL
Dim objCommand
'MsgBox("数据库准备连接0.5")
'strConnectionString = "Provider=MSDASQL;DSN=SQLSERVER;UID=sa;PWD=sa;" 
strConnectionString = "Provider=SQLOLEDB.1;Password=1233213;Persist Security Info=True; User ID = sa;Initial Catalog = TechStarDB; Data Source = 101.151.111.90"
'lngValue = HMIRuntime.Tags("Tag1").Read
'MsgBox("数据库准成功")
strSQL="Insert INTO WDTest (WD,NAME) VALUES ('"&status&"','"&name&"')"
'MsgBox(strSQL)
'strSQL = "EXEC [dbo].[p_equipmentStatusManage] N'"&equipmentCode&"',N'"&equipmentStatus&"',N'"&status&"'"
Set objConnection = CreateObject("ADODB.Connection")
objConnection.ConnectionString = strConnectionString
'MsgBox("数据库准备连接")
objConnection.Open
'MsgBox("数据库准成功")
Set objCommand = CreateObject("ADODB.Command")
With objCommand
    .ActiveConnection = objConnection
    .CommandText = strSQL
End With
objCommand.Execute

Set objCommand = Nothing
objConnection.Close
Set objConnection = Nothing

End Sub



Sub SaveEData(Equipment,EData)

OpenDataBaseSMG
Set objCommand = CreateObject("ADODB.Command")
'strSQL="Insert INTO test (A, B, C) VALUES ('"&GTSerialNumber&"', '"&GTSWeight&"', '"&GTAWeight&"')"
strSQL="INSERT INTO dbo.EEmsElectricMeter(ZXYG,MeterId)SELECT '"&EData&"', ObjId FROM dbo.EEmsMeter WHERE MeterNo='"&Equipment&"'"
'strSQL="Insert INTO WDTest (Name,WD) VALUES ('"&Equipment&"','"&EData&"')"
With objCommand
    .ActiveConnectioN = objConnection
    .CommandText = strSQL
End With
'Msgbox(Equipment)
objCommand.Execute
Set objCommand = Nothing
CloseDataBaseSMG
End Sub

Sub OpenDataBaseSMG
'******* define ADODB.Connection ********
Set objConnection = CreateObject("ADODB.Connection")
'strConnectionString = "Provider=SQLOLEDB.1;Password=1qazxsw2#EDC;Persist Security Info=True; User ID = sa;Initial Catalog = DSBoxDB; Data Source = 10.10.0.26"
strConnectionString = "Provider=SQLOLEDB.1;Password=techstar@123;Persist Security Info=True; User ID = sa;Initial Catalog = TechStarDB; Data Source = 10.15.1.9"
objConnection.ConnectionString = strConnectionString
'MsgBox("数据库连接成功1！")
objConnection.Open
'MsgBox("数据库连接成功2！")
Set objRecordset = CreateObject("ADODB.Recordset")
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
'************** Excute SQL **************
objCommand.CommandText = strSQL
End Sub


Sub CloseDataBaseSMG
Set objCommand = Nothing
objConnection.Close
Set objRecordset = Nothing
Set objConnection = Nothing
End Sub


Sub SaveWaterData(EData1,EData2,EData3,EData4,EData5,EData6,EData7,EData8,EData9,EData10,EData11,EData12,EData13,EData14,EData15)
OpenDataBaseSMG
Set objCommand = CreateObject("ADODB.Command")
'strSQL="Insert INTO test (A, B, C) VALUES ('"&GTSerialNumber&"', '"&GTSWeight&"', '"&GTAWeight&"')"
strSQL="UPDATE dbo.SEqmWaterRoomMon SET PT101='"&EData1&"',PT103='"&EData2&"',PT104='"&EData3&"',PT105='"&EData4&"',PT106='"&EData5&"',PT107='"&EData6&"',PT108='"&EData7&"',PT109='"&EData8&"',TT101='"&EData9&"',TT102='"&EData10&"',TT103='"&EData11&"',TT104='"&EData12&"',FT101='"&EData13&"',FT102='"&EData14&"',FT103='"&EData15&"' WHERE ObjId = 'CE562F9A-25F6-45BE-901F-479CA15C28DB'"
'strSQL="Insert INTO WDTest (Name,WD) VALUES ('"&Equipment&"','"&EData&"')"
With objCommand
    .ActiveConnectioN = objConnection
    .CommandText = strSQL
End With
'Msgbox(Equipment)
objCommand.Execute
Set objCommand = Nothing
CloseDataBaseSMG
End Sub

Sub SaveWaterSingleData(ColoumName,DataValue)

OpenDataBaseSMG
Set objCommand = CreateObject("ADODB.Command")
'strSQL="Insert INTO test (A, B, C) VALUES ('"&GTSerialNumber&"', '"&GTSWeight&"', '"&GTAWeight&"')"
strSQL="UPDATE dbo.SEqmWaterRoomMon SET " + ColoumName + " = '"&DataValue&"'  WHERE ObjId = 'CE562F9A-25F6-45BE-901F-479CA15C28DB'"
'strSQL="Insert INTO WDTest (Name,WD) VALUES ('"&Equipment&"','"&EData&"')"
With objCommand
    .ActiveConnectioN = objConnection
    .CommandText = strSQL
End With
'Msgbox(Equipment)
objCommand.Execute
Set objCommand = Nothing
CloseDataBaseSMG

End Sub

'连续报警-获取报警总条数
'Dim LX1

'Sub GetAlarmSettingCount ()
'OpenDataBaseSMG
'Set objRecordset=CreateObject("ADODB.Recordset")
'Set objCommand=CreateObject("ADODB.Command")
'strSQL="SELECT COUNT ( * ) FROM SysAlarmSeting_copy2 WHERE UsedFlag = 1 And DeleteFlag = 0 And EquipTypeName = '连续' And EquipIndex = '1' GROUP BY EquipTypeName"
'FROM 后面为读取的数据库名称
'标准的数据库操作属性和方法
'Set objCommand.ActiveConnection=objConnection
'objCommand.CommandType=1
'objCommand.CommandText=strSQL
'Set objRecordset=objCommand.Execute
'LX1 = objRecordset.Fields(0).Value
'CloseDataBaseSMG
'End Sub

'连续报警-配置信息
Sub SetAlarmSetting (Mstr,Dstr,Tpstr,Tstr)
OpenDataBaseSMG
Set objRecordset=CreateObject("ADODB.Recordset")
Set objCommand=CreateObject("ADODB.Command")
strSQL="SELECT AlarmType,DownLimit,TopLimit,AlarmName,AlarmCode FROM SysAlarmSeting_copy2 WHERE UsedFlag = 1 and DeleteFlag = 0 and EquipTypeName = '连续' And EquipIndex = '1' ORDER BY AlarmCode"
'FROM 后面为读取的数据库名称
'标准的数据库操作属性和方法
Set objCommand.ActiveConnection=objConnection
objCommand.CommandType=1
objCommand.CommandText=strSQL
Set objRecordset=objCommand.Execute
Dim m
m =70
'创建tag数组
Dim Mtag(70),DTag(70),TpTag(70),TTag(70)
Dim itemName,itemValue
For i = 1 To 70
 Mtag(i) = Mstr & i
 DTag(i) = Dstr & i
 TpTag(i) = Tpstr & i
 TTag(i) = Tstr & i
Next

'配置数据循环赋值给内部变量
If m > 0 Then
    For i = 1 To 70
        Dim Mpo,Tpo,Tppo,Dpo
        Mpo = Mtag(i)
        Tpo = TTag(i)
        Tppo = TpTag(i)
        Dpo = DTag(i)
        HMIRuntime.Tags(Mpo).Write objRecordset.Fields(3).Value
        HMIRuntime.Tags(Tpo).Write objRecordset.Fields(0).Value
        HMIRuntime.Tags(Tppo).Write objRecordset.Fields(2).Value
        HMIRuntime.Tags(Dpo).Write objRecordset.Fields(1).Value
        objRecordset.movenext
        'itemValue = HMIRuntime.Tags(po).Read
        'MsgBox(itemValue)
    Next
End If
CloseDataBaseSMG
End Sub


'循环判断是否报警
Sub JudgeAlaram(Mpa,Tpa,Tppa,Dpa,Spa,ValuePa)
'内部状态变量
Dim Mpo,Tpo,Tppo,Dpo,Spo
Mpo = HMIRuntime.Tags(Mpa).Read
Tpo = HMIRuntime.Tags(Tpa).Read
Tppo = HMIRuntime.Tags(Tppa).Read
Dpo = HMIRuntime.Tags(Dpa).Read
Spo = HMIRuntime.Tags(Spa).Read
' plc读数
Dim Valuepo
Valuepo = HMIRuntime.Tags(ValuePa).Read
' 判断是否报警 Tpo 1: true false 报警/// 2 ： 高位报警 /// 3 : 低位报警/// 4 ： 中间区域外报警 /// 5 ： 中间区域报警
If Tpo = 1 Then
  BoolAlarmJudge Valuepo,Spo,Spa,Mpo,ValuePa
Elseif Tpo = 2 Then
  TopAlarmJudge Valuepo,Spo,Tppo,Spa,Mpo,ValuePa
Elseif Tpo = 3 Then
  DownAlarmJudge Valuepo,Spo,Dpo,Spa,Mpo,ValuePa
Elseif Tpo = 4 Then
  TDAlarmJudge Valuepo,Spo,Tppo,Dpo,Spa,Mpo,ValuePa
End If
End Sub

'true false 报警
Sub BoolAlarmJudge(Valuepo,Spo,Spa,Mpo,ValuePa)
    ' 1: true false 报警
  If Valuepo = 1 Then
   ' 判断报警状态 如果不一致则更新数据库否则保持不变
    If Spo = 0 Then
       '更新数据库删除报警并修改Spo状态
       InsertAlarmMessage Mpo,ValuePa
       HMIRuntime.Tags(Spa).Write 1
       '否则保持不动
    End If 
  Else
    If Spo = 1 Then
       '更新数据库删除报警并修改Spo状态
       DeleteAlarmMessage ValuePa
       HMIRuntime.Tags(Spa).Write 0
       '否则保持不动
    End If
  End If
End Sub

'高位报警
Sub TopAlarmJudge(Valuepo,Spo,Tppo,Spa,Mpo,ValuePa)
    ' 高位报警
  If Valuepo > Tppo Then
    ' 判断报警状态 如果不一致则更新数据库否则保持不变
    If Spo = 0 Then
       '更新数据库删除报警并修改Spo状态
       InsertAlarmMessage Mpo,ValuePa
       HMIRuntime.Tags(Spa).Write 1
       '否则保持不动
    End If 
  Else
    If Spo = 1 Then
       '更新数据库删除报警并修改Spo状态
       DeleteAlarmMessage ValuePa
       HMIRuntime.Tags(Spa).Write 0
       '否则保持不动
    End If
  End If
End Sub

'低位报警
Sub DownAlarmJudge(Valuepo,Spo,Dpo,Spa,Mpo,ValuePa)
    ' 低位报警
  If Valuepo < Tppo Then
      ' 判断报警状态 如果不一致则更新数据库否则保持不变
    If Spo = 0 Then
       '更新数据库删除报警并修改Spo状态
       InsertAlarmMessage Mpo,ValuePa
       HMIRuntime.Tags(Spa).Write 1
       '否则保持不动
    End If 
  Else
    If Spo = 1 Then
       '更新数据库删除报警并修改Spo状态
       DeleteAlarmMessage ValuePa
       HMIRuntime.Tags(Spa).Write 0
       '否则保持不动
    End If
  End If
End Sub
 
 '中间区域外报警
Sub TDAlarmJudge(Valuepo,Spo,Tppo,Dpo,Spa,Mpo,ValuePa) 
    ' 中间区域报警
  If Valuepo > Tppo Or Valuepo < Dpo Then
      ' 判断报警状态 如果不一致则更新数据库否则保持不变
    If Spo = 0 Then
       '更新数据库删除报警并修改Spo状态
       InsertAlarmMessage Mpo,ValuePa
       HMIRuntime.Tags(Spa).Write 1
       '否则保持不动
    End If 
  Else
    If Spo = 1 Then
       '更新数据库删除报警并修改Spo状态
       DeleteAlarmMessage ValuePa
       HMIRuntime.Tags(Spa).Write 0
       '否则保持不动
    End If
  End If
End Sub

' 插入报警数据
Sub InsertAlarmMessage(Mpo,ValuePa)
OpenDataBaseSMG
Set objCommand = CreateObject("ADODB.Command")
Dim msg
msg = Mpo & HMIRuntime.Tags(ValuePa).Read
'strSQL="Insert INTO test (A, B, C) VALUES ('"&GTSerialNumber&"', '"&GTSWeight&"', '"&GTAWeight&"')"
strSQL="INSERT Into SysAlarmMessage_copy1 (EquipCode,Message,TagName) VALUES ('1011002','"&msg&"', '"&ValuePa&"')"
'strSQL="Insert INTO WDTest (Name,WD) VALUES ('"&Equipment&"','"&EData&"')"
With objCommand
    .ActiveConnectioN = objConnection
    .CommandText = strSQL
End With
'Msgbox(Equipment)
objCommand.Execute
Set objCommand = Nothing
CloseDataBaseSMG
End Sub
' 删除报警数据
Sub DeleteAlarmMessage(ValuePa)
OpenDataBaseSMG
Set objCommand = CreateObject("ADODB.Command")
'strSQL="Insert INTO test (A, B, C) VALUES ('"&GTSerialNumber&"', '"&GTSWeight&"', '"&GTAWeight&"')"
strSQL="Update SysAlarmMessage_copy1 set Status = 1 WHERE TagName = '"&ValuePa&"' and Status = 0"
'strSQL="Insert INTO WDTest (Name,WD) VALUES ('"&Equipment&"','"&EData&"')"
With objCommand
    .ActiveConnectioN = objConnection
    .CommandText = strSQL
End With

'Msgbox(Equipment)
objCommand.Execute
Set objCommand = Nothing
CloseDataBaseSMG
End Sub

VBS脚本请求webapi

VB代码

第一步，创建脚本对象，读出 VBStest.txt 文件

Private myScript As Object

Private Sub Form_Load()
    Call m_Initialize
End Sub

Public Sub m_Initialize()
Dim strScriptFile As String
Dim strScript As String
Dim intFile As Integer
intFile = FreeFile

strScriptFile = App.Path & "\Script\VBStest.txt"

If Dir(App.Path & "\Script\VBStest.txt") <> "" Then

    Open strScriptFile For Binary As #intFile
    strScript = Input(LOF(intFile), intFile)
    Close intFile

   Set myScript = CreateObject("ScriptControl")
   myScript.Language = "VBScript"
   'myScript.timeout = 1000
   myScript.AddCode strScript

End If
    
End Sub

第二步 脚本调用的方法

Public Function m_FCustom1(ByVal str调用名称 As String, ByVal str服务器参数 As String, ByRef str返回值 As String) As Boolean
On Error GoTo ErrTrap
Dim strA As String
 
    str返回值 = myScript.Run(str调用名称, str服务器参数)
    'm_FCustom1 = True

Exit Function
ErrTrap:
    MsgBox ("出错！" & CStr(Err) & " " & Error(Err))
        
On Error GoTo 0
End Function

第三步方法封装

第一种 Post方式

Private Sub Command3_Click()
Dim strA As String
    Call m_FCustom1("m_Post", "m_Post 11111111", strA)
    MsgBox ("返回值！" & strA)
 
End Sub
第二种  Get 方式

Private Sub Command4_Click()
    Dim strA As String
    Call m_FCustom1("m_Get", "m_Get  222222222", strA)
    MsgBox ("返回值！" & strA)
End Sub
第三种  Json 方式

Private Sub Command1_Click()
Dim strA As String
    Call m_FCustom1("m_PostTest", "m_Post  接口调试", strA)
    MsgBox ("返回值！" & strA)
End Sub

Function m_Get(strTelNumber)
Dim strA 
Dim http
Dim strUrl

    strUrl="http://localhost/callcenter2/VBStest.php?AAAA=1111"
    
     Set http = CreateObject("Msxml2.ServerXMLHTTP")
    'strA = http.open("GET", "http://www.baidu.com", False)
        strA = http.open("GET", strUrl, False)
    http.send

    MsgBox http.Status
    MsgBox http.responsetext


    m_Get = http.responsetext

    
End Function

Function m_Post(strTelNumber)
Dim strA 
Dim http
Dim strUrl

    strUrl="http://localhost/callcenter2/VBStest.php"
    
     set Http=createobject("MSXML2.XMLHTTP")
    'strA = http.open("POST", "http://www.baidu.com", False)     
    strA = http.open("POST", strUrl, False)     
    http.setRequestHeader "CONTENT-TYPE","application/x-www-form-urlencoded"
    http.Send "Text1=1AA&Text2=2BBBBB"
    
    MsgBox http.Status
    MsgBox http.responsetext


    m_Post = http.responsetext
    
End Function

'Jost方式
Function m_PostTest(strTelNumber)
Dim strA 
Dim http
Dim strUrl

    strUrl="http://211.140.196.159:9979/hlbr/api/callcenter/advisory"
    
     set Http=createobject("MSXML2.XMLHTTP")
    'strA = http.open("POST", "http://www.baidu.com", False)     
    strA = http.open("POST", strUrl, False)     
    http.setRequestHeader "CONTENT-TYPE","application/json"
    http.Send "{'id':'1'}"
    
    MsgBox http.Status
    MsgBox http.responsetext

    m_Post = http.responsetext
    
End Function
上一篇 下一篇

猜你喜欢

热点阅读