工作要求,需要编写vbs实现将wincc数据导出,估计以后也没机会再接触这门古董语言了,所以就记录一下。
因为wincc用得太少了,测试中会使用mysql代替。
业务逻辑
- 读取sql.txt文件,文件中每一行的格式为 id:select语句。
- 连接数据库,按行遍历执行查询,查询到的结果输出到指定文件夹下,得到以id命名的csv文件。
- 将执行过程、花费时间记录起来。
操作过程
- 准备sql文本文件
- 将代码复制到文本编辑器中,修改数据库连接参数、sql文本文件位置,输出文件夹位置,日志文件位置等
- 修改代码文件后缀为vbs
- 直接执行该文件即可
- 得到csv文件
代码
Sub Main
set fs =createobject("scripting.filesystemobject")
set sqlTxt=fs.opentextfile("C:\Users\15588\Desktop\vscode\sql.txt",1,false)
do while sqlTxt.atendofstream<>true
StartTime=Timer
queryStr=sqlTxt.readline
logs("开始执行: " & queryStr & "------------------------------")
queryStrArray=split(queryStr,":")
id=queryStrArray(0)
sSql=queryStrArray(1)
Dim db
Set db = New MySQLDB
db.Connect "数据库名", "root", "数据库密码", "ip", 3306
''' Set db = New WinccDB
''' db.Connect "WinCCOLEDBProvider.1", "CC_wincctes_18_07_11_22_23_06R", "WINCC-PC\WinCC"
If Err Then
MsgBox Err.Description
db.UnConnect
Exit Sub
End If
Call queryToCsv(id, db.oConn,sSql,"C:\Users\15588\Desktop\vscode\halodb\" & id & ".csv")
If Err Then
MsgBox Err.Description
db.UnConnect
Exit Sub
End If
db.UnConnect
Set db = Nothing
EndTime=Timer
Timelt=EndTime-StartTime
logs("结束执行,耗时(秒):"& Timelt)
loop
End Sub
Call Main
Class WinccDB
'''Current Error Code:
''' - 1
''' - 2
''' - 3
Public oConn
Private oRecSet
Private Sub Class_Initialize
End Sub
Private Sub Class_Terminate
UnConnect
Set dictErrDef = Nothing
'''logs( "Clean works complete.")
End Sub
'''' Public Methods ''''
Public Sub Connect(provider,cataloge,ds)
On Error Resume Next
Err.Clear
Dim sConnStr
'''Create CONNECTION STRING
sConnStr ="Provider=" & provider & ";Catalog=" & cataloge & ";Data Source=" & ds
'''logs( "sConnStr:" & sConnStr)
'''Create CONNECTION
Set oConn = CreateObject("ADODB.Connection")
oConn.ConnectionString = sConnStr
oConn.CursorLocation = 3
oConn.Open
If Err Then
MsgBox "Connection error"
MsgBox Err.Source
MsgBox Err.Description
Err.Raise vbObjectError + 1
Exit Sub
End If
If oConn.State = 0 Then
MsgBox "oConn.State = 0 "
Err.Raise vbObjectError + 1
Exit Sub
End If
'''MsgBox "Connection created."
End Sub
Public Sub UnConnect()
If oConn Is Nothing Then
Exit Sub
End If
oConn.Close
Set oConn = Nothing
End Sub
End Class
Class MySQLDB
'''Current Error Code:
''' - 1
''' - 2
''' - 3
Public oConn
Private oRecSet
Private Sub Class_Initialize
End Sub
Private Sub Class_Terminate
UnConnect
Set dictErrDef = Nothing
'''logs( "Clean works complete.")
End Sub
'''' Public Methods ''''
Public Sub Connect(db,uid,pwd,host,port)
On Error Resume Next
Err.Clear
Dim sConnStr
'''Create CONNECTION STRING
sConnStr = "DRIVER={MySQL ODBC 8.0 Unicode Driver};"
'sConnStr = "DRIVER={MySQL ODBC 5.2 ANSI Driver};"
sConnStr = sConnStr & "Database=" & db & ";"
sConnStr = sConnStr & "User=" & uid & ";"
sConnStr = sConnStr & "Password=" & pwd & ";"
sConnStr = sConnStr & "Server=" & host & ";"
sConnStr = sConnStr & "Port=" & port & ";"
sConnStr = sConnStr & "Option=3;"
'''Create CONNECTION
Set oConn = CreateObject("ADODB.Connection")
oConn.Open sConnStr
If Err Or oConn.State = 0 Then
MsgBox "oConn.State = 0 "
Err.Raise vbObjectError + 1
Exit Sub
End If
'''MsgBox "Connection created."
End Sub
Public Sub UnConnect()
If oConn Is Nothing Then
Exit Sub
End If
oConn.Close
Set oConn = Nothing
End Sub
End Class
Public Function queryToCsv(id,oConn,sql,path)
On Error Resume Next
Err.Clear
'''CREATE RECORDSET
Set oRecSet = CreateObject("ADODB.Recordset")
oRecSet.CursorLocation = 3
oRecSet.Open sql, oConn
If Err Then
MsgBox "query error"
MsgBox Err.Source
MsgBox Err.Description
Exit Function
End If
logs( "oRecSet.RecordCount:" & oRecSet.RecordCount)
Call RecordSet2Csv(id,oRecSet,path)
End Function
Public Function RecordSet2Csv(id,rs,path)
Dim field
Dim tmpStr
Dim c
c = 1
Set outFile = CreateObject("Scripting.FileSystemObject").CreateTextFile(path)
tmpStr=CsvValue_("id") & ","
For Each field In rs.Fields
If field.Name = "" Then
tmpStr=tmpStr & CsvValue_("(computed" & c & ")") & ","
c = c + 1
Else
tmpStr=tmpStr & CsvValue_(field.Name) & ","
End If
Next
outFile.WriteLine RTrimOne_(tmpStr)
c = 1
Do While Not rs.EOF
'''If c=65535 Then
''' MsgBox "记录数超过65535!请缩小导出时间范围!"
''' Exit Do
'''End If
tmpStr = CsvValue_(id) & ","
For Each field In rs.Fields
'''tmpStr=tmpStr & CsvValue_(field.Value) & ","
tmpStr=tmpStr & field.Value & ","
Next
outFile.WriteLine RTrimOne_(tmpStr)
rs.MoveNext
c = c+1
Loop
End Function
Private Function CsvValue_(val)
If IsNull(val) Then
CsvValue_ = ""
Else
CsvValue_ = """" & Replace(val, """", """""") & """"
End If
End Function
Private Function RTrimOne_(str)
RTrimOne_ = Left(str, Len(str) - 1)
End Function
Private Function logs(logdetail)
FilePath = "C:\Users\15588\Desktop\vscode\mysql2csv.log" 'LOG文件的路径
LOGDetail = logdetail 'LOG的内容
Set fso = CreateObject("scripting.FileSystemObject")
'判断LOG文件是否存在,如不存在,则按指定路径新建
If fso.FileExists(FilePath) = False Then
Set LOGFile = fso.CreateTextFile(FilePath, True)
LOGFile.Close
End If
Set LOGFile = fso.OpenTextFile(FilePath, 8, True) '8为追加
LOGFile.WriteLine Cstr(Now) & " : " & LOGDetail
LOGFile.Close
End Function
Q.E.D.