mdbb.frm

小型VB报表系统

Dim mn() As Integer
Dim lst As String
Dim midln As String
Dim lstln As String
Dim X As Long
Dim mw As Integer
Dim sp As Integer
Dim rs() As String

If List3.ListCount = 0 Then
  MsgBox Chr(13) + "请选择报表项目！   ", vbCritical
  Exit Sub
End If

If LTrim(RTrim(Text2.Text)) = "" Then
  MsgBox Chr(13) + "请设置报表名称！   ", vbCritical
  Text2.SetFocus
  Exit Sub
End If


On Error Resume Next

X = SendMessage(List1.hwnd, &H194, 0, ByVal 0&)
Label2.Caption = ""

'检测是否选用数值型
isdigi = False
If Check2.Value = 1 Or Check3.Value = 1 Then
  For i = 0 To List3.ListCount - 1
    '找项目
    List3.ListIndex = i
      If Data1.Recordset.Fields(List3.Text).Type = 7 Then
        isdigi = True
        Exit For
      End If
  Next i
End If
jdg:
If isdigi = False Then
  Check2.Value = 0
  Check3.Value = 0
End If

Frame3.Visible = False
Me.Refresh
ms.Label1.Caption = "准备生成【条件明细表】"
ms.Visible = True
ms.Refresh
Sleep (500)

'计算数据
Me.Refresh
ReDim rs(0 To zz + 1, 0 To List3.ListCount)

'项目名称
For J = 0 To List3.ListCount - 1
  List3.ListIndex = J
  If Data1.Recordset.Fields(List3.Text).Type = 7 Then
    rs(0, J) = "]" + List3.Text
  Else
    rs(0, J) = "[" + List3.Text
  End If
Next J
rs(0, List3.ListCount) = "]合计"

i = 0
Data1.Refresh
While Not Data1.Recordset.EOF
  '每个记录
  i = i + 1
  For J = 0 To List3.ListCount - 1
    '每个项目，横行和
    List3.ListIndex = J
    If Mid(rs(0, J), 1, 1) = "]" Then
      If Combo5.ListIndex > 0 Then
        rs(i, J) = chgdec(Data1.Recordset.Fields(List3.Text).Value, Combo5.ListIndex)
        If Check3.Value > 0 Then rs(i, List3.ListCount) = chgdec(Val(rs(i, List3.ListCount)) + Val(rs(i, J)), Combo5.ListIndex)
      Else
        rs(i, J) = CStr(Data1.Recordset.Fields(List3.Text).Value)
        If Check3.Value > 0 Then rs(i, List3.ListCount) = CStr(Val(rs(i, List3.ListCount)) + Val(rs(i, J)))
      End If
    Else
      rs(i, J) = Data1.Recordset.Fields(List3.Text).Value
    End If
  Next J
  ms.Label1.Caption = "正在计算数据，完成:" + CStr(Int(100 * i / zz)) + "%"
  ms.Label1.Refresh
  Data1.Recordset.MoveNext
Wend

'数值型项目纵向求和
If Check2.Value = 1 Then
  For i = 0 To List3.ListCount - 1
    If Mid(rs(0, i), 1, 1) = "]" Then
      For k = 1 To zz
        If Combo5.ListIndex > 0 Then
          rs(zz + 1, i) = chgdec(Val(rs(zz + 1, i)) + Val(rs(k, i)), Combo5.ListIndex)
        Else
          rs(zz + 1, i) = CStr(Val(rs(zz + 1, i)) + Val(rs(k, i)))
        End If
      Next k
    End If
  Next i
  For k = 1 To zz
    If Combo5.ListIndex > 0 Then
      rs(zz + 1, List3.ListCount) = chgdec(Val(rs(zz + 1, List3.ListCount)) + Val(rs(k, List3.ListCount)), Combo5.ListIndex)
    Else
      rs(zz + 1, List3.ListCount) = CStr(Val(rs(zz + 1, List3.ListCount)) + Val(rs(k, List3.ListCount)))
    End If
  Next k
End If
'"合计"
For i = 0 To List3.ListCount - 1
  If Mid(rs(0, i), 1, 1) = "[" Then
    rs(zz + 1, i) = "合计"
    Exit For
  End If
Next i


'计算每个项目的最大长度
ReDim mn(0 To List3.ListCount)
For i = 0 To List3.ListCount
  For J = 0 To zz + 1
    If J = 0 Then
      If mn(i) < strlens(Mid(rs(J, i), 2)) Then
        mn(i) = strlens(Mid(rs(J, i), 2))
        If mn(i) / 2 <> mn(i) \ 2 Then mn(i) = mn(i) + 1
      End If
    Else
      If mn(i) < strlens(rs(J, i)) Then
        mn(i) = strlens(rs(J, i))
        If mn(i) / 2 <> mn(i) \ 2 Then mn(i) = mn(i) + 1
      End If
    End If
  Next J
Next i
    
'确定中间行
If Check3.Value = 1 Then
  t = List3.ListCount
Else
  t = List3.ListCount - 1
End If
lst = "├"
For g = 1 To Combo7.ListIndex + 1
For i = 0 To t
  For J = 1 To mn(i) \ 2
    lst = lst + "─"
  Next J
  If i <> t Then lst = lst + "┼"
Next i
If g = Combo7.ListIndex + 1 Then
  lst = lst + "┤"
Else
  lst = lst + "┼"
End If
Next g
midln = lst

'确定最后行
If Check3.Value = 1 Then
  t = List3.ListCount
Else
  t = List3.ListCount - 1
End If
lst = "└"
For g = 1 To Combo7.ListIndex + 1
For i = 0 To t
  For J = 1 To mn(i) \ 2
    lst = lst + "─"
  Next J
  If i <> t Then lst = lst + "┴"
Next i
If g = Combo7.ListIndex + 1 Then
  lst = lst + "┘"
Else
  lst = lst + "┴"
End If
Next g
lstln = lst

'开始输出数据
Me.Refresh
List1.Clear
List1.AddItem LTrim(RTrim(Text2.Text))
List1.AddItem ""
List1.AddItem ""

'输出头
If Check3.Value = 1 Then
  t = List3.ListCount
Else
  t = List3.ListCount - 1
End If
lst = "┌"
For g = 1 To Combo7.ListIndex + 1
For i = 0 To t
  For J = 1 To mn(i) \ 2
    lst = lst + "─"
  Next J
  If i <> t Then lst = lst + "┬"
Next i
If g = Combo7.ListIndex + 1 Then
  lst = lst + "┐"
Else
 lst = lst + "┬"
End If
Next g
List1.AddItem lst
  
'输出项目名称
If Check3.Value = 1 Then
  t = List3.ListCount
Else
  t = List3.ListCount - 1
End If
lst = ""
For g = 1 To Combo7.ListIndex + 1
For i = 0 To t
  lst = lst + "│"
  lst = lst + Space((mn(i) - strlens(Mid(rs(0, i), 2))) \ 2) + Mid(rs(0, i), 2) + Space((mn(i) - strlens(Mid(rs(0, i), 2))) \ 2)
  If strlens(lst) / 2 <> strlens(lst) \ 2 Then lst = lst + " "
Next i
Next g
lst = lst + "│"
List1.AddItem lst
   
'输出表头中间行
List1.AddItem midln

If Check2.Value = 1 Then
  t1 = zz + 1
Else
  t1 = zz
End If

If Check3.Value = 1 Then
  t2 = List3.ListCount
Else
  t2 = List3.ListCount - 1
End If

'每个记录
g = 0
lst = ""
m = zz Mod (Combo7.ListIndex + 1)
For n = 1 To t1
  For i = 0 To t2
     '每个项目
     lst = lst + "│"
     If Check1.Value = 0 Then '自动选择
       If Mid(rs(0, i), 1, 1) = "]" Then
         If Val(rs(n, i)) = 0 Then rs(n, i) = " "  '清0
         lst = lst + Space(mn(i) - strlens(rs(n, i))) + rs(n, i)
       Else
         lst = lst + rs(n, i) + Space(mn(i) - strlens(rs(n, i)))
       End If
     Else '数据居中
       sp = mn(i) - strlens(rs(n, i))
       lst = lst + Space(sp \ 2 + (sp Mod 2)) + rs(n, i) + Space(sp \ 2)
     End If
  Next i
  g = g + 1
  If g = Combo7.ListIndex + 1 Then
    List1.AddItem lst + "│"
    If n < t1 Then List1.AddItem midln
    g = 0
    lst = ""
  Else
    '输出中间行或表尾
    If n = t1 Then
      '输出尾
      If m = 0 Then
        List1.AddItem lstln
      Else
        For g = 1 To Combo7.ListIndex + 1 - m
          For i = 0 To t2
            lst = lst + "│" + Space(mn(i))
          Next i
        Next g
        lst = lst + "│"
        List1.AddItem lst
        List1.AddItem lstln
      End If
    End If
  End If
  ms.Label1.Caption = "正在生成报表，完成:" + CStr(Int(100 * n / t1)) + "%"
  ms.Label1.Refresh
Next n
If Combo7.ListIndex = 0 Or m = 0 Then
   List1.AddItem lstln
End If
  
List1.ListIndex = 3
mw = strlens(List1.Text)
X = SendMessage(List1.hwnd, &H194, (mw + 1) * 8, ByVal 0&)
Label2.Caption = "共 " + CStr((List1.ListCount - 5) \ 2) + " 条记录"
Unload ms
Frame1.Visible = True
List1.Visible = True

Me.BackColor = QBColor(7)
Frame1.BackColor = Me.BackColor
Frame2.BackColor = Me.BackColor
Frame3.BackColor = Me.BackColor
Frame4.BackColor = Me.BackColor
Check1.BackColor = Me.BackColor
Check2.BackColor = Me.BackColor
Check3.BackColor = Me.BackColor
Me.Refresh

End Sub

Sub mdbtolisthz()
'┌──────┬───┐
'│　　　　　　│　　　│
'├──────┼───┤
'│　　　　　　│　　　│
'└──────┴───┘

'数据汇总表
Dim mn() As Integer
Dim lst As String
Dim midln As String
Dim lstln As String
Dim X As Long
Dim mw As Integer
Dim sp As Integer
Dim sj() As Double
Dim rs() As String

If List3.ListCount = 0 Then
  MsgBox Chr(13) + "请选择报表项目！   ", vbCritical
  Exit Sub
End If

If Combo6.Text = "" Then
  MsgBox Chr(13) + "请选择数据汇总项目！   ", vbCritical
  Exit Sub
End If

If LTrim(RTrim(Text2.Text)) = "" Then
  MsgBox Chr(13) + "请设置报表名称！   ", vbCritical
  Text2.SetFocus
  Exit Sub
End If


On Error Resume Next

X = SendMessage(List1.hwnd, &H194, 0, ByVal 0&)
Label2.Caption = ""

'检测是否选用数值型
List3.Visible = False
List5.Clear
For i = 0 To List3.ListCount - 1
  '找项目
  List3.ListIndex = i
  If Data1.Recordset.Fields(List3.Text).Type = 7 Then
    List5.AddItem List3.Text
  Else
    List2.AddItem List3.Text
  End If
Next i
List3.Clear
List3.Visible = True

If List5.ListCount > 0 Then
  For i = 0 To List5.ListCount - 1
    List5.ListIndex = i
    List3.AddItem List5.Text
  Next i
Else
  MsgBox Chr(13) + "您选择的项目中没有数值型项目！  ", vbCritical
  Exit Sub
End If

Frame3.Visible = False
Me.Refresh
ms.Label1.Caption = "准备生成【数据汇总表】"
ms.Visible = True
ms.Refresh
Sleep (500)

'计算数据
Me.Refresh
ReDim sj(0 To List4.ListCount, 0 To List3.ListCount)
ReDim rs(-1 To List4.ListCount, -1 To List3.ListCount)
For i = 0 To List4.ListCount - 1
  '每个记录
  List4.ListIndex = i
  rs(i, -1) = List4.Text
  For J = 0 To List3.ListCount - 1
    '每个项目
    List3.ListIndex = J
    rs(-1, J) = List3.Text
    '项目求和
    Data1.Refresh
    While Not Data1.Recordset.EOF
      If Data1.Recordset.Fields(Combo6.Text).Value = List4.Text Then
        sj(i, J) = sj(i, J) + Data1.Recordset.Fields(List3.Text).Value
      End If
      Data1.Recordset.MoveNext
    Wend
  Next J
  ms.Label1.Caption = "正在计算数据，完成:" + CStr(Int(100 * i / (List4.ListCount - 1))) + "%"
  ms.Label1.Refresh
Next i
rs(-1, -1) = Combo6.Text
rs(-1, List3.ListCount) = "合计"
rs(List4.ListCount, -1) = "合计"

'数值型项目纵向求和
If Check2.Value = 1 Then
  For i = 0 To List3.ListCount - 1
    For J = 0 To List4.ListCount - 1
      sj(List4.ListCount, i) = sj(List4.ListCount, i) + sj(J, i)
    Next J
  Next i
End If

'数值型项目横行求和
If Check3.Value = 1 Then
  For i = 0 To List4.ListCount
    For J = 0 To List3.ListCount - 1
      sj(i, List3.ListCount) = sj(i, List3.ListCount) + sj(i, J)
    Next J
  Next i
End If

'数字型项目保留n位小数
If Combo5.ListIndex > 0 Then
  For i = 0 To List4.ListCount
    For J = 0 To List3.ListCount
      rs(i, J) = chgdec(sj(i, J), Combo5.ListIndex)
    Next J
  Next i
Else
  For i = 0 To List4.ListCount
    For J = 0 To List3.ListCount
      rs(i, J) = CStr(sj(i, J))
    Next J
  Next i
End If

'计算每个项目的最大长度
ReDim mn(-1 To List3.ListCount)
For i = -1 To List3.ListCount
  For J = -1 To List4.ListCount
    If mn(i) < strlens(rs(J, i)) Then
      mn(i) = strlens(rs(J, i))
      If mn(i) / 2 <> mn(i) \ 2 Then mn(i) = mn(i) + 1
    End If
  Next J
Next i
    
'确定中间行
If Check3.Value = 1 Then
  t = List3.ListCount
Else
  t = List3.ListCount - 1
End If
lst = "├"
For g = 1 To Combo7.ListIndex + 1
For i = -1 To t
  For J = 1 To mn(i) \ 2
    lst = lst + "─"
  Next J
  If i <> t Then lst = lst + "┼"
Next i
If g = Combo7.ListIndex + 1 Then