form1.frm

用友内部插件

    MsgBox Err.Description
End Sub

Private Sub cmd_CancelAudit_Click()
    Dim o_api As BizAPI
    Dim o_adaptersvr As BizAdapterService
    
    Dim o_errMsg As New MSXML2.DOMDocument
    Dim o_header As New DOMDocument
    
    On Error GoTo ErrHanlde
    
    Set o_adaptersvr = New BizAdapterService
    
    'o_adaptersvr.ConfigFile = "F:\zsf\二次开发\Document\ConfigFile\UFSoft.U8.Business.Interface.config"
    
    Set o_api = o_adaptersvr.GetBizAPI("SCMPU/PU/CancelconfirmPO", "860")
    
    If o_api Is Nothing Then
        MsgBox "Get API SCMPU/PU/CancelAudit not Success!"
        Exit Sub
    End If
    
    If Not o_header.loadXML(txt_Header.Text) Then
        Err.Raise -1, "", o_header.parseError.reason
    End If
    
    Call o_api.Parameters("VoucherType").setValue(1)
    Call o_api.Parameters("domHead").setValue(o_header)
    

    Dim sRev As String
    sRev = o_api.Execute(g_oLogin, g_oConnection)
    
    If sRev = "" Then
        MsgBox "OK"
    Else
        MsgBox "Error in CancelAuditting a new vouch." & vbCrLf & sRev
    End If
    
    Exit Sub
ErrHanlde:
    MsgBox Err.Description
End Sub

Private Sub cmd_Delete_Click()
    Dim o_api As BizAPI
    Dim o_adaptersvr As BizAdapterService
    
    Dim o_errMsg As New DOMDocument
    Dim o_header As New DOMDocument, o_body As New DOMDocument
    
    Set o_adaptersvr = New BizAdapterService
    
    'o_adaptersvr.ConfigFile = "F:\zsf\二次开发\Document\ConfigFile\UFSoft.U8.Business.Interface.config"
    
    Set o_api = o_adaptersvr.GetBizAPI("SCMPU/PU/Delete", "860")
    
    If o_api Is Nothing Then
        MsgBox "Get API SCMPU/PU/Delete not Success!"
        Exit Sub
    End If
    
    If Not o_header.loadXML(txt_Header.Text) Then
        Err.Raise -1, "", o_header.parseError.reason
    End If
    If Not o_body.loadXML(txt_Body.Text) Then
        Err.Raise -1, "", o_header.parseError.reason
    End If
    
    Call o_api.Parameters("VoucherType").setValue(1)
    Call o_api.Parameters("domHead").setValue(o_header)
    Call o_api.Parameters("domBody").setValue(o_body)
    Call o_api.Parameters("CurDom").setValue(o_errMsg)
    
    Dim bl_Success As String
    bl_Success = o_api.Execute(g_oLogin, g_oConnection)
    If bl_Success = "" Then
        MsgBox "OK"
    Else
        MsgBox bl_Success
    End If
    Exit Sub
ErrHanlde:
    MsgBox Err.Description
End Sub

Private Sub cmd_Login_Click()
    Dim loc_oNetLogin As Object
    Dim bl_Success As Boolean
    
    On Error GoTo ErrHandler
    
    bl_Success = False
    
    Set loc_oNetLogin = CreateObject("UFSoft.U8.Framework.Login.UI.clsLogin")
    If loc_oNetLogin.login_2("DP") Then
        loc_oNetLogin.SubLogin ("PU")

        g_sUserToken = loc_oNetLogin.userToken
        
        '创建旧Login
        Set g_oLogin = New U8Login.clsLogin
        Call g_oLogin.ConstructLogin(g_sUserToken)
        g_oLogin.TaskId = loc_oNetLogin.gettaskid("PU")
        '登陆产品（库存管理）
        If g_oLogin.Login("PU") Then
        
            g_sConnStr = g_oLogin.UfDbName
            
            Set g_oConnection = New ADODB.Connection
            g_oConnection.Open g_sConnStr
            
            bl_Success = True
        Else
            MsgBox "登陆失败:" & g_oLogin.ShareString
        End If
    Else
        MsgBox "登陆失败:" & g_oLogin.ShareString
    End If
    Me.cmd_AddVoucher.Enabled = bl_Success
    Me.cmd_Audit.Enabled = bl_Success
    Me.cmd_CancelAudit.Enabled = bl_Success
    Me.cmd_Delete.Enabled = bl_Success
    Me.cmd_LoadVoucher.Enabled = bl_Success
    Me.cmd_Update.Enabled = bl_Success
    Me.cmd_APIXMLSchema.Enabled = bl_Success
    Exit Sub
ErrHandler:
    MsgBox VBA.Err.Description
End Sub


Private Sub cmd_Update_Click()
    Dim o_api As BizAPI
    Dim o_adaptersvr As BizAdapterService
    
    Dim o_header As New DOMDocument, o_body As New DOMDocument
    Dim sHeadId As String
    
    On Error GoTo ErrHanlde
    
    Set o_adaptersvr = New BizAdapterService
    
    'o_adaptersvr.ConfigFile = "F:\zsf\二次开发\Document\ConfigFile\UFSoft.U8.Business.Interface.config"
    
    Set o_api = o_adaptersvr.GetBizAPI("SCMPU/PU/Update", "860")
    
    If o_api Is Nothing Then
        MsgBox "Get API SCMPU/PU/Update not Success!"
        Exit Sub
    End If
    
    If Not o_header.loadXML(txt_Header.Text) Then
        Err.Raise -1, "", o_header.parseError.reason
    End If
    If Not o_body.loadXML(txt_Body.Text) Then
        Err.Raise -1, "", o_header.parseError.reason
    End If
    
    '更新单据表头表体[测试工程使用]
    Call SetBodyItemValue(o_body, "editprop", "M")
    
    
    Call o_api.Parameters("VoucherType").setValue(1)
    Call o_api.Parameters("domHead").setValue(o_header)
    Call o_api.Parameters("domBody").setValue(o_body)
    Call o_api.Parameters("VoucherState").setValue(1)
'    Call o_api.Parameters("sBillType").setValue("purbill")
'    Call o_api.Parameters("bPositive").setValue(True)
    
    'sHeadId = ""
    'Call o_api.Parameters("curID").setValue(sHeadId)
    
    g_oConnection.BeginTrans
    
    Dim s_Success As String
    s_Success = o_api.Execute(g_oLogin, g_oConnection, True)
    
    If s_Success = "" Then
        g_oConnection.CommitTrans
        MsgBox "ok"
    Else
        g_oConnection.RollbackTrans
        MsgBox "error:" & vbCrLf & s_Success
    End If

    Exit Sub
ErrHanlde:
    MsgBox Err.Description
End Sub

Private Sub Form_Load()
    If Not g_oLogin Is Nothing Then Set g_oLogin = Nothing
    If Not g_oConnection Is Nothing Then Set g_oConnection = Nothing
End Sub

Private Sub cmd_LoadVoucher_Click()
    Dim o_header As DOMDocument, o_body As DOMDocument, str_error As String
    
    Dim o_api As BizAPI
    Dim o_adaptersvr As BizAdapterService
    
    Dim bl_Success As Boolean
    
    txt_Header.Text = ""
    txt_Body.Text = ""
    
    Set o_adaptersvr = New BizAdapterService
    'o_adaptersvr.ConfigFile = "F:\zsf\二次开发\Document\ConfigFile\UFSoft.U8.Business.Interface.config"
    
    Set o_api = o_adaptersvr.GetBizAPI("SCMPU/PU/Load", "860")
    
    

    
    If o_api Is Nothing Then
        MsgBox "Get API SCMPU/PU/Load not Success!"
        Exit Sub
    End If
    Dim obj As New BaseTypeParameterHandler
    
    Call o_api.Parameters("VoucherType").setValue(1)
'    Call o_api.Parameters("VoucherType").setValue(4)
'    Call o_api.Parameters("sBillType").setValue("purbill")
'    Call o_api.Parameters("bPositive").setValue(True)


    If txt_VoucherId.Text <> "" Then
        Call o_api.Parameters("varVoucherID").setValue(txt_VoucherId.Text)
    End If

    Dim sRev As String
    sRev = o_api.Execute(g_oLogin, g_oConnection)

    If sRev = "" Then
        MsgBox "OK"
    Else
        MsgBox "Error in Loading a new vouch." & vbCrLf & sRev
    End If
    
    Set o_header = o_api.Parameters("domHead").getValue()
    Set o_body = o_api.Parameters("domBody").getValue()
    
    txt_Header.Text = o_header.xml
    txt_Body.Text = o_body.xml

    
End Sub


Private Function SetBodyItemValue(ByVal DomBody As DOMDocument, ByVal sKey As String, ByVal newValue As String, Optional R As Long)
    Dim ele As IXMLDOMElement
    Dim ndList As IXMLDOMNodeList
    Set ndList = DomBody.selectNodes("//z:row")
    If ndList Is Nothing Then Exit Function
    
    sKey = LCase(sKey)
    
    If IsMissing(R) Or R <= 0 Then
        For Each ele In ndList
            Call ele.setAttribute(sKey, newValue)
        Next
    Else
        If Not ndList.Item(R).Attributes.getNamedItem(sKey) Is Nothing Then
            ndList.Item(R).Attributes.getNamedItem(sKey).nodeValue = newValue
        End If
    End If
    
End Function


Private Function SetHeadItemValue(ByVal DomHead As DOMDocument, ByVal sKey As String, ByVal newValue As String) As String
    sKey = LCase(sKey)
    If Not DomHead.selectSingleNode("//z:row").Attributes.getNamedItem(sKey) Is Nothing Then
         DomHead.selectSingleNode("//z:row").Attributes.getNamedItem(sKey).nodeValue = newValue
    End If
End Function