inputcls.cls

将xml格式的文件导入到 数据库中,将xml格式的文件导入到 数据库中

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "inputcls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private EAIobj As Object
Private sxml As New DOMDocument
Private Sub EAIinput(sxml As String, strRet As String)
strRet = EAIobj.Process(sxml)
End Sub
Private Sub init()
If EAIobj Is Nothing Then
    Set EAIobj = CreateObject("U8Distribute.iDistribute")
End If
End Sub
Public Sub UNinit()
Set EAIobj = Nothing
End Sub
Private Sub movefile(sFilename As String, spath As String, dpath As String)
Dim str As String
str = CStr(Date)
str = str & "-" & Replace(Time, ":", "-")
Call FileCopy(spath & "\" & sFilename, dpath & "\" & str & "_" & sFilename)
Call Kill(spath & "\" & sFilename)



End Sub
Private Sub writelog(logname As String, logpath As String)
Dim filename As String
Dim A, s, S1 As String
filename = CStr(Date) & ".TXT"
Dim FreeNum As Integer
FreeNum = FreeFile
Open logpath & "\" & filename For Append As FreeNum

Print #FreeNum, CStr(Time) & "   " & logname
'Print #FreeNum, S1
Close FreeNum
'关闭文件之后重新以Output的模式打开。
'Print #FreeNum, CStr(Time) & logname
'Close FreeNum

End Sub
Public Sub indata(types As Integer, sFilename As String, spath As String, okpath As String, okpathlog As String, unokpath As String, unokpathlog As String)
Dim aa As New inputcls
Dim Booleans As Boolean
Dim dxml As New DOMDocument
Dim logname As String
Dim str As String
init
sxml.Load spath & sFilename
If LCase(sxml.selectSingleNode("//ufinterface").Attributes.getNamedItem("proc").nodeValue) <> LCase("add") Then
    logname = "保存失败！ 操作符号不正确。"
    GoTo Errexit
End If

If types = 1 Then  '销售发货单
    Call Checkdata(sxml, "销售发货单", "//consignment/header/returnflag", "0", Booleans, logname)
    If Booleans = True Then
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 销售发货单数据格式不正确。"
        GoTo Errexit
    End If

ElseIf types = 2 Then '销售退货单
    Call Checkdata(sxml, "销售发货单", "//consignment/header/returnflag", "1", Booleans, logname)
    If Booleans = True Then
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 销售退货单数据格式不正确。"
        GoTo Errexit
    End If

ElseIf types = 3 Then

    If (LCase(sxml.selectSingleNode("//ufinterface").Attributes.getNamedItem("display").nodeValue) = LCase("收款单")) Then
        '保存
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 收款单数据格式不正确。"
        GoTo Errexit
    End If

ElseIf types = 4 Then '其他出库单
    Call Checkdata(sxml, "出库单", "//storeout/header/vouchtype", "09", Booleans, logname)
    If Booleans = True Then
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 其他出库单数据格式不正确。"
        GoTo Errexit
    End If

ElseIf types = 5 Then '其他入库单
    Call Checkdata(sxml, "入库单", "//storein/header/vouchtype", "08", Booleans, logname)
    If Booleans = True Then
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 其他入库单数据格式不正确。"
        GoTo Errexit
    End If

ElseIf types = 6 Then '调拨单
If LCase(sxml.selectSingleNode("//ufinterface").Attributes.getNamedItem("display").nodeValue) = LCase("调拨单") Then
        '保存
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 调拨单数据格式不正确。"
        GoTo Errexit
    End If

ElseIf types = 7 Then '材料出库单
    Call Checkdata(sxml, "出库单", "//storeout/header/vouchtype", "11", Booleans, logname)
    If Booleans = True Then
        EAIinput sxml.xml, str
    Else
        logname = "保存失败！ 材料出库单数据格式不正确。"
        GoTo Errexit
    End If

End If

'保存结果
dxml.loadXML str

    If Not dxml.selectSingleNode("//item").Attributes.getNamedItem("dsc") Is Nothing Then
        If LCase(Trim(dxml.selectSingleNode("//item").Attributes.getNamedItem("dsc").nodeValue)) = LCase("OK") Then

            logname = "保存成功！" & dxml.xml
            Call writelog("[" & sFilename & "]  " & logname, okpathlog)
            Call movefile(sFilename, spath, okpath)
        Else
            logname = "保存失败！" & dxml.xml
            Call writelog("[" & sFilename & "]  " & logname, unokpathlog)
            Call movefile(sFilename, spath, unokpath)
        End If
    Else
            logname = "保存失败！" & dxml.xml
            Call writelog("[" & sFilename & "]   " & logname, unokpathlog)
            Call movefile(sFilename, spath, unokpath)
    End If
    Exit Sub
Errexit:
    Call writelog("[" & sFilename & "]  " & logname & Err.Description, unokpathlog)
    Call movefile(sFilename, spath, unokpath)
End Sub
Public Sub movedata(Optional SuperGrid As Object)
Dim spath  As String
Dim item As String
Dim i As Integer
Dim FreeNum As Integer
Dim str As String
Dim types  As String
Dim sFilename  As String
Dim okpath  As String
Dim okpathlog  As String
Dim unokpath  As String
Dim unokpathlog  As String

If Not (SuperGrid Is Nothing) Then
    With SuperGrid
         For i = 1 To 7
            spath = SuperGrid.TextMatrix(i, 2) & "\"
            item = Dir(spath, vbArchive)
            While Len(item) > 0
                Call indata(CInt(SuperGrid.TextMatrix(i, 0)), item, SuperGrid.TextMatrix(i, 2), SuperGrid.TextMatrix(i, 3), SuperGrid.TextMatrix(i, 4), SuperGrid.TextMatrix(i, 5), SuperGrid.TextMatrix(i, 6))
                item = Dir
            Wend
        Next i
    End With
Else
    FreeNum = FreeFile 'Freenum表示一个空闲的文件号
    Open App.Path + "\mypatch.txt" For Input As FreeNum
    i = 1
    Do Until EOF(FreeNum) '循环，直到文件结尾。Eof函数用来判断文件是否读完
    Line Input #FreeNum, str
        If i <= 7 Then
        str = Decrypt(Trim(str), "a")
        types = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(types) + 1))
        
        sFilename = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(sFilename) + 1))
        
        spath = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(spath) + 1))
                
        okpath = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(okpath) + 1))
        
        okpathlog = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(okpathlog) + 1))
                
        unokpath = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(unokpath) + 1))
                
        unokpathlog = get_leftstr(str, ",")
        str = Right(str, Len(str) - (Len(unokpathlog) + 1))
        
        spath = spath & "\"
        item = Dir(spath, vbArchive)
        While Len(item) > 0
            Call indata(CInt(types), item, spath, okpath, okpathlog, unokpath, unokpathlog)
            item = Dir
        Wend
        End If
        i = i + 1
    Loop
    Close FreeNum
End If
End Sub
'检查数据格式
Private Sub Checkdata(DataXml As DOMDocument, vouchername As String, TypeName As String, TypeVaLue As String, Flag As Boolean, Errstr As String)
'    If ((LCase(sxml.selectSingleNode("//ufinterface").Attributes.getNamedItem("display").nodeValue) = LCase("销售发货单")) And (LCase(sxml.selectSingleNode("//consignment/header").selectSingleNode("returnflag").Text) = LCase("0"))) Then
Dim i As Integer
Dim lens As Integer
    Flag = False
    If LCase(DataXml.selectSingleNode("//ufinterface").Attributes.getNamedItem("display").nodeValue) = LCase(vouchername) Then
        Flag = True
        lens = DataXml.selectSingleNode("//ufinterface").childNodes.length
        For i = 0 To lens - 1
            If LCase(DataXml.selectSingleNode("//ufinterface").childNodes(i).selectSingleNode(TypeName).Text) <> LCase(TypeVaLue) Then
                Flag = False
                Errstr = "数据错误！ 第" & CStr(i + 1) & "行  单据类型不正确，请检查。" & vouchername
            End If
        Next i
    Else
        Errstr = "数据错误！ 当前导入的不是" & vouchername & "，请检查。"
    End If
End Sub
'取出 str_str_key 关键子左边的字符
Private Function get_leftstr(str As String, str_key As String) As String
Dim tempstr As String
Dim i As Long
    If str_key <> "" Then
        i = InStr(1, str, str_key, vbTextCompare)
        If i > 0 Then
            tempstr = Left(str, i - 1)
        End If
        get_leftstr = tempstr
    Else
        get_leftstr = ""
    End If
    
End Function


Public Function Alert(strAlertXml As String) As String
'MsgBox Time

    Call movedata
    Alert = "<alert success='1' description='EAI OK !  " & CStr(Date) & CStr(Time) & "' > </alert>"
'        alert="<alert success='0' description="当前无可预警信息！" account='001' year='2005'>"
    
End Function

  Public Function Encrypt(PlainStr As String, key As String) As String
  Dim Char     As String, KeyChar       As String, NewStr       As String
  Dim Pos     As Integer
  Dim i     As Integer, Side1       As String, Side2       As String
  Pos = 1
     
  'This   loop   encrypts   the   data.
  For i = 1 To Len(PlainStr)
      Char = Mid(PlainStr, i, 1)
      KeyChar = Mid(key, Pos, 1)
      NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
      If Pos = Len(key) Then Pos = 0
      Pos = Pos + 1
  Next i
     
  'This   is   a   little   trick   to   make   it   slightly   harder   to   crack.
  'However,   the   chances   of   this   operation   firing   is   50/50
  'because   the   length   of   the   string   must   be   divisable   by   2.
  If Len(NewStr) Mod 2 = 0 Then
      Side1 = StrReverse(Left(NewStr, (Len(NewStr) / 2)))
      Side2 = StrReverse(Right(NewStr, (Len(NewStr) / 2)))
      NewStr = Side1 & Side2
  End If
     
  Encrypt = NewStr
  End Function
Public Function Decrypt(PlainStr As String, key As String) As String
  Dim Char     As String, KeyChar       As String, NewStr       As String
  Dim Pos     As Integer
  Dim i     As Integer, Side1       As String, Side2       As String
  Pos = 1
     
  'This   is   a   little   trick   to   make   it   slightly   harder   to   crack.
  'However,   the   chances   of   this   operation   firing   is   50/50
  'because   the   length   of   the   string   must   be   divisable   by   2.
  If Len(PlainStr) Mod 2 = 0 Then
      Side1 = StrReverse(Left(PlainStr, (Len(PlainStr) / 2)))
      Side2 = StrReverse(Right(PlainStr, (Len(PlainStr) / 2)))
      PlainStr = Side1 & Side2
  End If
     
  'This   loop   decrypts   the   data.
  For i = 1 To Len(PlainStr)
      Char = Mid(PlainStr, i, 1)
      KeyChar = Mid(key, Pos, 1)
      NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
      If Pos = Len(key) Then Pos = 0
      Pos = Pos + 1
  Next i
     
  Decrypt = NewStr
  End Function