mdbm.bas

小型VB报表系统

Attribute VB_Name = "mdbm"
'转换成大写字符串
Public Declare Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String

'防止将重复项目添加到列表框中API声明
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'使窗口总在最前端API声明
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

'制作渐变的窗口背景色API声明
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hbrush As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
End Type

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function RemoveDirectory Lib "kernel32" Alias "RemoveDirectoryA" (ByVal lpPathName As String) As Long

Public tbfn As String
Public dbfn As String


Public Function formtop(formx As Form, showflag As Boolean)
'使窗口总在最前端模块
'调用示范：1、call formtop(form1,true)    2、call formtop(form1,false)
'调用说明：1、将form1窗口置于最前         2、取消form1窗口置于最前
If showflag = True Then
  SetWindowPos formx.hwnd, -1, 0, 0, 0, 0, 2 Or 1
Else
  SetWindowPos formx.hwnd, -2, 0, 0, 0, 0, 2 Or 1
End If
End Function

Public Function strlens(teststr As String) As Integer
  strlens = LenB(StrConv(teststr, vbFromUnicode))
End Function

Public Function formbc(formx As Form, colorr As Integer, colorg As Integer, colorb As Integer)
'制作渐变的窗口背景色模块，必须在Form_paint事件中调用
'调用示范：1、call formbc(me,0,0,255)  2、call formbc(me,0,255,0)
'调用说明：1、制作蓝色过渡背景色       2、制作绿色过渡背景色
On Error Resume Next
Dim hbrush As Integer
Dim oldmode As Integer
Dim retval As Integer
Dim stepsize As Integer
Dim tpx As Integer
Dim fillarea As RECT
If colorr < 0 Then colorr = 0
If colorg < 0 Then colorg = 0
If colorb < 0 Then colorb = 0
If colorr > 255 Then colorr = 255
If colorg > 255 Then colorg = 255
If colorb > 255 Then colorb = 255
oldmode = formx.ScaleMode
formx.ScaleMode = 3
stepsize = 1 + formx.ScaleHeight / 480
fillarea.Left = 0
fillarea.Right = formx.ScaleWidth
fillarea.Top = 0
fillarea.Bottom = stepsize
For tpx = 1 To 480
  hbrush = CreateSolidBrush(RGB(colorr, colorg, colorb))
  retval = FillRect(formx.hdc, fillarea, hbrush)
  retval = DeleteObject(hbrush)
  colorr = colorr - 1
  colorg = colorg - 1
  colorb = colorb - 1
  If colorr < 0 Then colorr = 0
  If colorg < 0 Then colorg = 0
  If colorb < 0 Then colorb = 0
  fillarea.Top = fillarea.Bottom
  fillarea.Bottom = fillarea.Bottom + stepsize
Next tpx
formx.ScaleMode = oldmode
End Function

'列表框数据自动分页打印模块
Function listdataprint(listobj As ListBox, titleline As Integer, lineapage As Integer, lastline As Boolean, printfontsize As Integer, leftchar As Integer, topline As Integer, noline As Integer) As Boolean
'参数说明：
'listobj    列表框对象，即要打印的数据所在的列表框
'titleline  打印时的标题行数，即每页始终打印listobj中前titleline行
'lineapage  每页打印的行数，程序将按此参数自动分页打印
'lastline   该参数值为True时，每页最后将打印listobj中最后一行，若listobj中是表格，该参数就非常有用
'           该参数值为False时，则每页最后不打印listobj中最后一行
'topline    上边距行
Dim intpage As Integer            '整数页变量
Dim totalpage As Integer          '总页数变量
Dim lastpageline As Integer       '最后一页行数
Dim pagewidth As Integer          '所需纸张宽度
Dim pageheight As Integer          '所需纸张高度
Dim iloop As Integer              '循环变量
Dim jloop As Integer              '循环变量
Dim retval As Integer             '返回变量
Dim pwpara As Single
Dim phpara As Single
Dim linewidth As Integer
Dim pt As String

'检查listobj中是否有打印数据，无数据则返回
If listobj.ListCount = 0 Then
  listdataprint = False
  MsgBox Chr(13) + "没有数据可以打印！   ", vbCritical
  Exit Function
End If
'检测标题行数，小于1则返回
If titleline < 1 Then
  listdataprint = False
  MsgBox Chr(13) + "标题行数至少应为１！   ", vbCritical
  Exit Function
End If
'隐藏打印对象listobj，便于加快数据提取速度
listobj.Visible = False
'计算相关参数
intpage = (listobj.ListCount - titleline) \ lineapage
lastpageline = (listobj.ListCount - titleline) Mod lineapage
If lastpageline > 0 Then
  totalpage = intpage + 1
Else
  totalpage = intpage
End If
'计算所需纸张宽度
linewidth = 0
For iloop = 0 To listobj.ListCount - 1
  listobj.ListIndex = iloop
  'If linewidth < LenB(StrConv(listobj.Text, vbFromUnicode)) Then
  '  linewidth = LenB(StrConv(listobj.Text, vbFromUnicode))
    'LenB、StrConv两个函数用来返回中英文字符串的宽度（单位：Byte,即英文字符长度）
  If linewidth < strlens(listobj.Text) Then
    linewidth = strlens(listobj.Text)
  End If
Next iloop
listobj.ListIndex = 0
'每个英文字符的打印宽度
If printfontsize = 12 Then
  pwpara = 2.12
Else
  pwpara = 1.41
End If
pagewidth = Int(linewidth * pwpara) + 1
'计算所需纸张高度
'每行的打印高度
If printfontsize = 12 Then
  phpara = 4.225
Else
  phpara = 2.825
End If
pageheight = Int((titleline + lineapage + topline) * phpara) + 3
'确认打印
retval = MsgBox(Chr(13) + "标准纸张：" + Chr(13) + Chr(13) + "B5(16开)：  195×270(mm)   " + Chr(13) + "A4：        210×296(mm)   " + Chr(13) + "宽行(8开)： 388×270(mm)   " + Chr(13) + Chr(13) + Chr(13) + "本次打印共 " + CStr(totalpage) + " 页。   " + Chr(13) + Chr(13) + "所需纸张大小：宽度:" + CStr(pagewidth) + "mm，高度:" + CStr(pageheight) + "mm。   " + Chr(13) + Chr(13) + "是否开始打印作业？    ", vbQuestion + vbYesNo)
If retval = 6 Then
  '打印整数页部分
  If intpage > 0 Then
   '从第1页到第intpage页
   For iloop = 1 To intpage
     If MsgBox(Chr(13) + "是否打印第 " + CStr(iloop) + "/" + CStr(totalpage) + " 页？ 　  ", vbQuestion + vbYesNo) = vbYes Then
      '当前标题，第一行用黑体，字体大小大3，其余行用宋体
      Printer.FontName = "宋体"
      Printer.FontSize = printfontsize
      For jloop = 1 To topline
        Printer.Print ""
      Next jloop
      For jloop = 0 To titleline - 1
        listobj.ListIndex = jloop
        If jloop = 0 Then
          Printer.FontName = "黑体"
          Printer.FontSize = printfontsize + 3
          If strlens(listobj.Text) * (printfontsize + 3) / printfontsize > linewidth Then
             If leftchar > 0 Then
               Printer.Print Space(leftchar) + listobj.Text
             Else
               Printer.Print listobj.Text
             End If
          Else
             If leftchar > 0 Then
               Printer.Print Space(leftchar) + Space(Int((linewidth - strlens(listobj.Text) * (printfontsize + 3) / printfontsize) * 0.38)) + listobj.Text
             Else
               Printer.Print Space(Int((linewidth - strlens(listobj.Text) * (printfontsize + 3) / printfontsize) * 0.38)) + listobj.Text
             End If
          End If
        Else
          Printer.FontName = "宋体"
          Printer.FontSize = printfontsize
          If jloop = noline Then
            If totalpage > 1 Then
              If leftchar > 0 Then
                pt = "页号：" + CStr(iloop) + "/" + CStr(totalpage)
                Printer.Print Space(leftchar) + listobj.Text + Space(linewidth - strlens(listobj.Text) - strlens(pt) - 1) + pt
              Else
                pt = "页号：" + CStr(iloop) + "/" + CStr(totalpage)
                Printer.Print listobj.Text + Space(linewidth - strlens(listobj.Text) - strlens(pt) - 1) + pt
              End If
            Else
              If leftchar > 0 Then
                Printer.Print Space(leftchar) + listobj.Text
              Else
                Printer.Print listobj.Text
              End If
            End If
          Else
            If leftchar > 0 Then
              Printer.Print Space(leftchar) + listobj.Text
            Else
              Printer.Print listobj.Text
            End If
          End If
        End If
      Next jloop
      '当前页除标题外的其它内容
      Printer.FontName = "宋体"
      Printer.FontSize = printfontsize
      '判断当前页是否打印listobj中最后一行
      If lastline = True Then
        '报表数据
        For jloop = (iloop - 1) * lineapage + titleline To iloop * lineapage + titleline - 2
          listobj.ListIndex = jloop
          If leftchar > 0 Then
            Printer.Print Space(leftchar) + listobj.Text
          Else
            Printer.Print listobj.Text
          End If
        Next jloop
        listobj.ListIndex = listobj.ListCount - 1
        If leftchar > 0 Then
          Printer.Print Space(leftchar) + listobj.Text
        Else
          Printer.Print listobj.Text
        End If
      Else
        '非报表数据
        For jloop = (iloop - 1) * lineapage + titleline To iloop * lineapage + titleline - 1
          listobj.ListIndex = jloop
          If leftchar > 0 Then
            Printer.Print Space(leftchar) + listobj.Text
          Else
            Printer.Print listobj.Text
          End If
        Next jloop
      End If
      '开始打印
      Printer.EndDoc
     End If
   Next iloop
  End If
  '最后一页
  If lastpageline > 0 Then
    If MsgBox(Chr(13) + "是否打印第 " + CStr(totalpage) + "/" + CStr(totalpage) + " 页？ 　  ", vbQuestion + vbYesNo) = vbYes Then
    '当前页标题，第一行用黑体，字体大小大3，其余行用宋体
    Printer.FontName = "宋体"
    Printer.FontSize = printfontsize
    For jloop = 1 To topline
      Printer.Print ""
    Next jloop
    For jloop = 0 To titleline - 1
      listobj.ListIndex = jloop
      If jloop = 0 Then
        Printer.FontName = "黑体"
        Printer.FontSize = printfontsize + 3
        If strlens(listobj.Text) * (printfontsize + 3) / printfontsize > linewidth Then
          If leftchar > 0 Then
            Printer.Print Space(leftchar) + listobj.Text
          Else
            Printer.Print listobj.Text
          End If
        Else
          If leftchar > 0 Then
            Printer.Print Space(leftchar) + Space(Int((linewidth - strlens(listobj.Text) * (printfontsize + 3) / printfontsize) * 0.38)) + listobj.Text
          Else
            Printer.Print Space(Int((linewidth - strlens(listobj.Text) * (printfontsize + 3) / printfontsize) * 0.38)) + listobj.Text
          End If
        End If
      Else
        Printer.FontName = "宋体"
        Printer.FontSize = printfontsize
        If jloop = noline Then
          If totalpage > 1 Then
            If leftchar > 0 Then
              pt = "页号：" + CStr(totalpage) + "/" + CStr(totalpage)
              Printer.Print Space(leftchar) + listobj.Text + Space(linewidth - strlens(listobj.Text) - strlens(pt) - 1) + pt
            Else
              pt = "页号：" + CStr(totalpage) + "/" + CStr(totalpage)
              Printer.Print listobj.Text + Space(linewidth - strlens(listobj.Text) - strlens(pt) - 1) + pt
            End If
          Else
            If leftchar > 0 Then
              Printer.Print Space(leftchar) + listobj.Text
            Else
              Printer.Print listobj.Text
            End If
          End If
        Else
          If leftchar > 0 Then
            Printer.Print Space(leftchar) + listobj.Text
          Else
            Printer.Print listobj.Text
          End If
        End If
      End If
    Next jloop
    '当前页除标题外的其它内容及最后一行
    Printer.FontName = "宋体"
    Printer.FontSize = printfontsize
    For jloop = (totalpage - 1) * lineapage + titleline To listobj.ListCount - 1
      listobj.ListIndex = jloop
      If leftchar > 0 Then
        Printer.Print Space(leftchar) + listobj.Text
      Else
        Printer.Print listobj.Text
      End If
    Next jloop
    '开始打印
    Printer.EndDoc
    End If
  End If
End If
'显示打印对象listobj
listobj.Visible = True
End Function

'MSFlexGrid控件按某项目排序函数
Function GridSort(cgrid As MSFlexGrid, ccol As Integer, sType As Integer)
  cgrid.Redraw = False
  cgrid.Row = 1
  cgrid.RowSel = cgrid.Rows - 1
  cgrid.Col = ccol
  cgrid.Sort = sType
  cgrid.Redraw = True
  cgrid.TopRow = 1
End Function

Public Function chgdec(num As Double, dec As Integer) As String
  tmp = CStr(Round(num, dec))
  p = InStr(1, tmp, ".")
  If p > 0 Then
    If p = 1 Then
      tmp = "0" + tmp + "000"
    Else
      If Mid(tmp, 1, 2) = "-." Then
        tmp = "-0." + Mid(tmp, 3) + "000"
      Else
        tmp = tmp + "000"
      End If
    End If
  Else
    tmp = tmp + ".000"
  End If
  p = InStr(1, tmp, ".")
  chgdec = Mid(tmp, 1, p + dec)
End Function

'列表框、组合框项目快速查询
Public Function FindFirstMatch(ByVal ctlSearch As Control, ByVal SearchString As String, ByVal Exact As Boolean) As Integer
'最后一个参数为ture时进行精确查询，为false时模糊查询
Dim cIndex As Long
On Error Resume Next
If TypeOf ctlSearch Is ComboBox Then
  '组合框
  If Exact Then
    cIndex = SendMessage(ctlSearch.hwnd, &H158, -1, ByVal SearchString)
  Else
    cIndex = SendMessage(ctlSearch.hwnd, &H14C, -1, ByVal SearchString)
  End If
ElseIf TypeOf ctlSearch Is ListBox Then
  '列表框
  If Exact Then
    cIndex = SendMessage(ctlSearch.hwnd, &H1A2, -1, ByVal SearchString)
  Else
    cIndex = SendMessage(ctlSearch.hwnd, &H18F, -1, ByVal SearchString)
  End If
End If
FindFirstMatch = cIndex
End Function