mdbb.frm

小型VB报表系统

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 msftolisthz()
'┌──────┬───┐
'│　　　　　　│　　　│
'├──────┼───┤
'│　　　　　　│　　　│
'└──────┴───┘

'数据汇总表
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 = ""

'排序
GridSort msf, Combo2.ListIndex - 1, 1


'检测是否选用数值型
List3.Visible = False
List5.Clear
For i = 0 To List3.ListCount - 1
  '找项目
  List3.ListIndex = i
  For k = 0 To msf.Cols - 1
    If msf.TextArray(k) = List3.Text Then
      If msf.ColAlignment(k) = 7 Then
        List5.AddItem List3.Text
      Else
        List2.AddItem List3.Text
      End If
      Exit For
    End If
  Next k
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)
 
For i = 0 To List4.ListCount
  For J = 0 To List3.ListCount
    sj(i, J) = 0
    rs(i, J) = ""
  Next J
Next i
 
'计算数据
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 p = 0 To msf.Cols - 1
    If msf.TextArray(p) = Combo6.Text Then Exit For
  Next p
  For J = 0 To List3.ListCount - 1
    '每个项目
    List3.ListIndex = J
    rs(-1, J) = List3.Text
    '找数据项目
    For k = 0 To msf.Cols - 1
      If msf.TextArray(k) = List3.Text Then
        '项目求和
        For m = 1 To msf.Rows - 1
          If msf.TextMatrix(m, p) = List4.Text Then
            sj(i, J) = sj(i, J) + Val(msf.TextMatrix(m, k))
          End If
        Next m
      End If
    Next k
  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
  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 = -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
  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 = -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
  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 = -1 To t
  lst = lst + "│"
  lst = lst + Space((mn(i) - strlens(rs(-1, i))) \ 2) + rs(-1, i) + Space((mn(i) - strlens(rs(-1, i))) \ 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 = List4.ListCount
Else
  t1 = List4.ListCount - 1
End If

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

'每个记录
g = 0
lst = ""
m = List4.ListCount Mod (Combo7.ListIndex + 1)
For n = 0 To t1
  For i = -1 To t2
     '每个项目
     lst = lst + "│"
     If Check1.Value = 0 Then '自动选择
       If i > -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 = -1 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)) + "%"
  Me.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



Private Sub c0_Click(Index As Integer)
On Error Resume Next
vt(Index + 1).SetFocus

End Sub

Private Sub c1_Click(Index As Integer)
vt(0).SetFocus
If Index = 0 And c1(0).Text <> "" Then
  c1(1).Clear
  c1(1).AddItem "="
  c1(1).AddItem "<>"
  c1(1).AddItem ">"
  c1(1).AddItem ">="
  c1(1).AddItem "<"
  c1(1).AddItem "<="
  If msf.ColAlignment(c1(0).ListIndex) = 1 Then
    c1(1).AddItem " like "
  End If
End If


End Sub

Private Sub c2_Click(Index As Integer)
vt(1).SetFocus
If Index = 0 And c2(0).Text <> "" Then
  c2(1).Clear
  c2(1).AddItem "="
  c2(1).AddItem "<>"
  c2(1).AddItem ">"
  c2(1).AddItem ">="
  c2(1).AddItem "<"
  c2(1).AddItem "<="
  If msf.ColAlignment(c2(0).ListIndex) = 1 Then
    c2(1).AddItem " like "
  End If
End If

End Sub

Private Sub c3_Click(Index As Integer)
vt(2).SetFocus
If Index = 0 And c3(0).Text <> "" Then
  c3(1).Clear
  c3(1).AddItem "="
  c3(1).AddItem "<>"
  c3(1).AddItem ">"
  c3(1).AddItem ">="
  c3(1).AddItem "<"
  c3(1).AddItem "<="
  If msf.ColAlignment(c3(0).ListIndex) = 1 Then
    c3(1).AddItem " like "
  End If
End If


End Sub

Private Sub c4_Click(Index As Integer)
vt(3).SetFocus
If Index = 0 Then
  c4(1).Clear
  c4(1).AddItem "="
  c4(1).AddItem "<>"
  c4(1).AddItem ">"
  c4(1).AddItem ">="
  c4(1).AddItem "<"
  c4(1).AddItem "<="
  If msf.ColAlignment(c4(0).ListIndex) = 1 Then
    c4(1).AddItem " like "
  End If
End If


End Sub

Private Sub Check2_Click()
If Check2.Value = 1 Or Check3.Value = 1 Then
  Combo7.ListIndex = 0
End If
End Sub

Private Sub Check3_Click()
If Check2.Value = 1 Or Check3.Value = 1 Then
  Combo7.ListIndex = 0
End If
End Sub

Private Sub Combo2_Click()
On Error Resume Next
'排序-升序
If Combo2.ListIndex > 0 Then
  GridSort msf, Combo2.ListIndex - 1, 1
  Combo6.Clear
  List4.Clear
  For i = 0 To msf.Cols - 1
    If msf.ColAlignment(i) <> 7 Then
      Combo6.AddItem msf.TextArray(i)
    End If
  Next i
End If
End Sub

Private Sub Combo6_Click()
Command9.Enabled = False
ms.Label1.Caption = "正在检测项目，请稍后..."
ms.Visible = True
ms.Refresh
Sleep (500)
List4.Clear
If Combo2.ListIndex > 0 Then
  For i = 0 To msf.Cols - 1
    If msf.TextArray(i) = Combo6.Text Then Exit For
  Next i
  If i <= msf.Cols - 1 Then
    F