vbs.txt

wincc访问SQL数据库时需要使用的VBS脚本程序段

Sub OnClick(ByVal Item)               

Dim sDsn 
Dim sSer 
Dim sCon 
Dim sSql 
Dim conn 
Dim oRs 
Dim oCom 
Dim sPro 
Dim m,n,s
Dim a,b,c
Dim Listview1
Dim oItem 

Dim strDateTime 

Dim iMS

Set Listview1 = ScreenItems("Control1") 

Dim TimeFrom
Dim TimeTo

Set TimeFrom= HMIRuntime.Tags("TimeFrom")
TimeFrom.Read


Set TimeTo= HMIRuntime.Tags("TimeTo")
TimeTo.Read 

sPro = "Provider=WinCCOLEDBProvider.1;"
sDsn = "Catalog=CC_accessme_08_08_14_20_08_46R;"
sSer = "Data Source=.\WinCC"
sCon = sPro + sDsn + sSer


'sSql = "Tag:R,'ProcessValueArchive\tag1','2008-08-14 07:32:00.000','2008-08-15 07:34:00.000'" 
sSql = "Tag:R,'ProcessValueArchive\tag1','" + TimeFrom.Value + "','" + TimeTo.Value + "'" 

MsgBox "Open with:" & vbCr & sCon & vbCr & sSql & vbCr 

Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = sCon
conn.CursorLocation = 3
conn.Open
Set oRs = CreateObject("ADODB.Recordset")
Set oCom = CreateObject("ADODB.Command")
oCom.CommandType = 1
Set oCom.ActiveConnection = conn
oCom.CommandText = sSql 
Set oRs = oCom.Execute
m = oRs.Fields.Count

If (m > 0) Then 
oRs.MoveFirst


ListView1.ColumnHeaders.Clear 

ListView1.ColumnHeaders.Add , , CStr(oRs.Fields(1).Name), 200   ' DateTime 

ListView1.ColumnHeaders.Add , , "MS", 100                        ' Milisecond 

ListView1.ColumnHeaders.Add , , CStr(oRs.Fields(0).Name), 100   ' DateTime 

ListView1.ColumnHeaders.Add , , CStr(oRs.Fields(2).Name), 100   ' DateTime 

ListView1.ColumnHeaders.Add , , CStr(oRs.Fields(3).Name), 80   ' DateTime 

ListView1.ColumnHeaders.Add , , CStr(oRs.Fields(4).Name), 50   ' DateTime 

Do While Not oRs.EOF


SplitDateTimeAndMs oRs.Fields(1).Value, strDateTime, iMS    'Split Milisecond from DateTime 

s = FormatDateTime(strDateTime, 2) & " " & FormatDateTime(strDateTime, 3) 

Set oItem = ListView1.ListItems.Add() 

oItem.Text = s 

oItem.SubItems(1) = iMS 

oItem.SubItems(2) = oRs.Fields(0).Value 

oItem.SubItems(3) = FormatNumber(oRs.Fields(2).Value, 2) 

oItem.SubItems(4) = Hex(oRs.Fields(3).Value) 

oItem.SubItems(4) = Hex(oRs.Fields(3).Value) 



oRs.MoveNext
Loop

End If 
oRs.Close
Set oRs = Nothing
conn.Close
Set conn = Nothing
End Sub