导出结果.frm

用友U8财务软件VB源程序, 本版本为2002年版本

            QueryIt
        Case "columns"
            If m_objColSet.setCol Then
                SetSql "refresh"
            End If
        Case "selall"
            ocxVchList.AllSelect
        Case "desel"
            ocxVchList.AllNone
        Case "export"
            ExportMe
        Case "refresh"
            Reload
        Case "preview"
            Preview
        Case "print"
            PrintIt
        Case "output"
            Output
        Case "import"
            ImportMe
        Case "help"
            SendKeys "{F1}"
        Case "quit"
            Quit
        Case Else
    End Select
    
    If Button.key <> "quit" Then
        ocxCtbTool.RefreshEnable
    End If
End Sub

Public Function Workable() As Boolean
    Workable = False
    If ocxVchList.Rows > 1 Then
        Workable = True
    End If
End Function

Public Sub ExportMe()
    Dim i As Integer
    Dim cnt As Integer
    Dim ocols As U8colset.clsCols
    Dim tmp As String
    Dim rtn As Integer
    Dim rs As New ADODB.Recordset
    Dim sql As String
    Dim doc As New DOMDocument
    
    On Error GoTo last
    Set ocols = m_objColSet.GetColProperties
    i = 0
    
    m_objCon.BeginTrans
    
    While i < ocxVchList.Rows - 1
        If ocxVchList.TextMatrix(i + 1, 0) = "Y" Then
            m_objCon.Execute "update fd_transactions set importexport_flag='3' where transactions_id ='" & ocxVchList.TextMatrix(i + 1, ocols("transactions_id").iColPos) & "'"
            cnt = cnt + 1
        End If
        i = i + 1
    Wend
    
    If cnt = 0 Then
        iShowMsg "没有选择导出记录!"
        Exit Sub
    End If
    
    m_objBack.Mark "export", m_iType
    sql = m_objBack.GetSqlString & " where importexport_flag='3' "
    rs.Open sql, m_objCon
       
    m_objBack.AppendExportBatch rs, m_objCon
    tmp = m_objBack.ExecCmd(m_objCon)
    doc.loadXML tmp
    rtn = m_objAid.iSuccess(doc)
    
    If rtn = 0 Then
        iShowMsg "导出数据成功!"
    ElseIf rtn = 1 Then
        frmExportInfo.SetInfo (tmp)
        frmExportInfo.Show vbModal
        SetSql "refresh"
    Else
        Err.Raise 1
    End If
    
    m_objCon.CommitTrans
    SetSql "refresh"
    Exit Sub
last:
    frmExportInfo.SetInfo (tmp)
    frmExportInfo.Show vbModal
    m_objCon.RollbackTrans
    Err.clear
End Sub

Public Sub ImportMe()
    Dim XmlOut As New DOMDocument
    Dim str As String
    
    On Error GoTo last
    
    comFile.Filename = ""
    comFile.Flags = cdlOFNOverwritePrompt Or cdlOFNPathMustExist Or cdlOFNLongNames Or cdlOFNExtensionDifferent Or cdlOFNHideReadOnly
    comFile.Filter = "Xml Files(*.xml)|*.xml"
    comFile.ShowOpen
    
    If Trim(comFile.Filename) = "" Then
        Exit Sub
    ElseIf Len(Dir(comFile.Filename)) = 0 Then
        iShowMsg "指定的文件不存在!"
        Exit Sub
    End If
    
    m_objnb.Transact comFile.Filename, str, m_objCon
    
    XmlOut.loadXML str
    If m_objAid.iSuccess(XmlOut) = 0 Then
        iShowMsg "全部数据导入成功!"
    Else
        frmExportInfo.SetInfo str
        frmExportInfo.Show vbModal
    End If
    Exit Sub
last:
    iShowMsg "导入失败!"
End Sub

Private Sub LoadToolPic()
    With IltTool.ListImages
         .clear
         .Add , "print", LoadResPicture(314, vbResBitmap)
         .Add , "preview", LoadResPicture(312, vbResBitmap)
         .Add , "output", LoadResPicture(263, vbResBitmap)
         
         .Add , "import", LoadResPicture(343, vbResBitmap)
         .Add , "export", LoadResPicture(347, vbResBitmap)
         
         .Add , "columns", LoadResPicture(102, vbResBitmap)
         .Add , "refresh", LoadResPicture(154, vbResBitmap)
         .Add , "query", LoadResPicture(331, vbResBitmap)
         
         .Add , "desel", LoadResPicture(208, vbResBitmap)
         .Add , "selall", LoadResPicture(207, vbResBitmap)
         
         .Add , "help", LoadResPicture(396, vbResBitmap)
         .Add , "quit", LoadResPicture(1118, vbResBitmap)

         
    End With
    
    With tlbTool
         Set .ImageList = IltTool
        
         .Buttons("print").Image = "print"
         .Buttons("preview").Image = "preview"
         .Buttons("output").Image = "output"
         
         .Buttons("selall").Image = "selall"
         .Buttons("desel").Image = "desel"
         
         .Buttons("export").Image = "export"
         .Buttons("import").Image = "import"
         
         .Buttons("refresh").Image = "refresh"
         .Buttons("columns").Image = "columns"
         .Buttons("query").Image = "query"
         
         .Buttons("help").Image = "help"
         .Buttons("quit").Image = "quit"
    End With
    
    Me.Icon = LoadResPicture(109, vbResIcon)
End Sub

Private Sub SetButtonState()
    With tlbTool
        If Not Workable Then
            .Buttons("print").Enabled = False
            .Buttons("preview").Enabled = False
            .Buttons("output").Enabled = False
            
            .Buttons("selall").Enabled = False
            .Buttons("desel").Enabled = False
            .Buttons("export").Enabled = False
        Else
            .Buttons("print").Enabled = True
            .Buttons("preview").Enabled = True
            .Buttons("output").Enabled = True
            
            .Buttons("selall").Enabled = True
            .Buttons("desel").Enabled = True
            .Buttons("export").Enabled = True
        End If
    End With
End Sub

Private Sub QueryIt()
    frmExportQuery.Show vbModal
End Sub

Private Sub Reload()
    SetSql "refresh"
End Sub

Private Sub Preview()
    ocxVchList.VchLstPreview
End Sub

Private Sub PrintIt()
    ocxVchList.VchLstPrint
End Sub

Private Sub Output()
    ocxVchList.VchLstPrintToFile
End Sub

Private Sub Quit()
    Unload Me
End Sub

'快捷键处理
Public Function bShortCut(KeyCode As Integer, Shift As Integer, Optional other As String) As Boolean
    Dim cmd As String
    Dim butt As MsComctlLib.Button
    
    On Error Resume Next
    bShortCut = True
    Select Case KeyCode
        Case vbKeyF1    '帮助
            cmd = "help"
        Case vbKeyF3
            cmd = "query"
        Case vbKeyF4    '刷新,退出
            If Shift = 1 Then
                cmd = "quit"
            Else
                cmd = "refresh"
            End If
        Case vbKeyF5    '增加新记录
            cmd = "import"
        Case vbKeyF6    '保存
            cmd = "output"
        Case vbKeyP '打印
            cmd = "print"
        Case vbKeySeparator, vbKeyReturn
            SendKeys "{tab}"
        Case Else
            bShortCut = False
            Exit Function
    End Select
    
    '激发菜单事件
    Set butt = tlbTool.Buttons(cmd)
    If Not butt Is Nothing Then
        If butt.Visible And butt.Enabled Then
            tlbTool_ButtonClick butt
        End If
    End If
End Function