使用计划汇总表.frm

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

Private Sub MergeRow()
  Dim sT As Integer, ed As Integer
  Dim tmp As String, attr As String
  Dim Col As Integer
  Dim i As Integer
  
  sT = 0
  ed = 0
  Col = ocxCell.GetCols(0) - 1
  For i = 1 To Col
    attr = GetField(i, "mergeid")
    If attr = "" And tmp = "" Then '接着看下面的是否要合并
        tmp = ""
    ElseIf attr <> tmp Then
        If tmp <> "" Then
            MergeIt sT, ed
            tmp = ""
        End If
        tmp = attr
        sT = i
        ed = i
    Else
        ed = i
    End If
  Next
  
  '合并小计
  ocxCell.MergeCells 1, ocxCell.GetRows(0) - 1, 3, ocxCell.GetRows(0) - 1
  ocxCell.SetCellAlign 1, ocxCell.GetRows(0) - 1, 0, 36
End Sub

Private Sub MergeIt(sT As Integer, ed As Integer)
    Dim i As Integer
    Dim Row As Integer
    Dim val As String, tmp As String
    Dim f As Integer, l As Integer
    
    Row = ocxCell.GetRows(0) - 1
    For i = 2 To Row
        val = ocxCell.GetCellString(sT, i, 0)
        If tmp <> val Then
            If tmp <> "" Then
                ocxCell.MergeCells sT, f, ed, l
                ocxCell.SetCellAlign sT, f, 0, 36
            End If
            tmp = val
            f = i
            l = i
        Else
            l = i
        End If
    Next
End Sub

Private Sub MakeHead()
    Dim i As Integer
    Dim Col As Integer
    
    Col = m_objTable.documentElement.childNodes.length
    ocxCell.SetCols Col + 1, 0
    
    i = 1
    While i <= Col
        ocxCell.SetColWidth 0, CInt(GetField(i, "width")), i, 0
        ocxCell.SetCellString i, 1, 0, GetField(i, "caption")
        ocxCell.SetCellAlign i, 1, 0, 36
        ocxCell.SetCellBackColor i, 1, 0, ocxCell.FindColorIndex(RGB(255, 128, 255), 1)
        ocxCell.SetCellFont i, 1, 0, ocxCell.FindFontIndex("宋体", 1)
        ocxCell.SetCellFontSize i, 1, 0, 9
        i = i + 1
    Wend
    ocxCell.SetFixedCol 1, 3
End Sub

Private Sub Query()
    Dim doc As New DOMDocument
    doc.loadXML "<query/>"
    doc.documentElement.Text = m_sWhere
    m_objMgr.GetReport doc, m_objContent, doc
    If PrintError(doc) Then Exit Sub
    If Not m_objContent Is Nothing Then
        MakeHead
        MakeRow
        MergeRow
    Else
        ocxCell.ResetContent
        SetTableState
        MakeHead
        iShowMsg "没有满足条件的数据统计!"
    End If
    SetButtonState
End Sub

Private Sub Output()
    Dim doc As DOMDocument
    Dim root As IXMLDOMElement
    
    On Error Resume Next
    comFile.Filename = ""
    comFile.DefaultExt = "xls"
    comFile.Flags = cdlOFNOverwritePrompt Or cdlOFNPathMustExist Or cdlOFNLongNames Or cdlOFNExtensionDifferent Or cdlOFNHideReadOnly
    comFile.Filter = "Text Files(*.txt)|*.txt|Excel Files(*.xls)|*.xls|Html Files(*.html)|*.html|Xml Files(*.xml)|*.xml|Mdb Files(*.mdb)|*.mdb"
    comFile.FilterIndex = 1
    comFile.ShowSave
    If Trim(comFile.Filename) <> "" And Not m_objContent Is Nothing Then
        Select Case comFile.FilterIndex
            Case 1 '文本文件
                HeadToTable
                If ocxCell.ExportTextFile(" ", comFile.Filename, 0) = 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
                RemovePrintPart
            Case 2 'excel文件
                HeadToTable
                If ocxCell.ExportExcelFile(comFile.Filename) = 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
                RemovePrintPart
            Case 3 'html文件
                HeadToTable
                If ocxCell.ExportHtmlFile(comFile.Filename) = 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
                RemovePrintPart
            Case 4 'xml文件
                Set doc = m_objAid.objGenerateUFDom("roottag", "fd")
                Set root = m_objAid.objSelectRootTag(doc)
                root.appendChild m_objTable.documentElement
                root.appendChild m_objContent.documentElement
                doc.Save comFile.Filename
                If Err.Number <> 0 Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case 5 '
                If Not bRsToMdb(comFile.Filename, m_sWhere, "fd_collection") Then
                    iShowMsg "输出失败!"
                Else
                    iShowMsg "输出成功!"
                End If
            Case Else
        End Select
    End If
End Sub

Private Sub LoadToolPic()
    With IltTool.ListImages
         .clear
         .Add , "print", LoadResPicture(314, vbResBitmap)
         .Add , "preview", LoadResPicture(312, vbResBitmap)
         .Add , "output", LoadResPicture(313, vbResBitmap)
         .Add , "query", LoadResPicture(331, vbResBitmap)
         .Add , "refresh", LoadResPicture(154, 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("query").Image = "query"
         .Buttons("refresh").Image = "refresh"
         .Buttons("help").Image = "help"
         .Buttons("quit").Image = "quit"
    End With
    Me.Icon = LoadResPicture(109, vbResIcon)
End Sub


'添加打印的头部,和尾部
Private Sub HeadToTable()
    '插入头部6行
    Dim Row As Integer
    
    ocxCell.InsertRow 1, 4, 0
    
    ocxCell.SetCellString 1, 1, 0, lbTitle.Caption
    ocxCell.SetCellFontSize 1, 1, 0, 16
    ocxCell.MergeCells 1, 1, 6, 1
    ocxCell.SetCellAlign 1, 1, 0, 36
    
    ocxCell.SetCellString 1, 3, 0, "币种: " & cboCurName.Text
    ocxCell.SetCellString 4, 3, 0, "单位:万元"
      
    
    ocxCell.MergeCells 1, 3, 3, 3
    ocxCell.SetCellAlign 1, 3, 0, 36
    ocxCell.MergeCells 4, 3, 5, 3
    ocxCell.SetCellAlign 4, 3, 0, 36
End Sub

Private Sub RemovePrintPart()
    ocxCell.DeleteRow 1, 4, 0
End Sub

Private Sub PrintMe()
    HeadToTable
    ocxCell.PrintPara 1, 0, 1, 1
    ocxCell.PrintSheet 1, 0
    RemovePrintPart
End Sub

Private Sub Preview()
    HeadToTable
    ocxCell.PrintPara 1, 0, 1, 1
    ocxCell.PrintPreview 1, 0
    RemovePrintPart
End Sub

Private Sub QueryIt()
    frmCollectionQuery.Show vbModal
    If frmCollectionQuery.where = "" Then
        Exit Sub
    Else
        frmCollection.Cur = frmCollectionQuery.Cur
        m_sWhere = fore_part & frmCollectionQuery.where
        Unload frmCollectionQuery
        Query
    End If
End Sub

Private Sub Reload()
    If m_sWhere <> "" Then
        Query
    End If
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 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

Private Sub SetButtonState()
    With tlbTool
        If m_objContent Is Nothing Then
            .Buttons("output").Enabled = False
            .Buttons("print").Enabled = False
            .Buttons("preview").Enabled = False
        Else
            .Buttons("output").Enabled = True
            .Buttons("print").Enabled = True
            .Buttons("preview").Enabled = True
        End If
    End With
End Sub