about.bas

KTV管理系统,实现了基本的日常操作.程序有不完善之处,请自修升级修改.

Attribute VB_Name = "ABOUT"
Option Explicit
'调用帮助文件
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'定义报表全局数据集
Public rtpRS As Recordset
Public rtpTitle As String

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
'将rtpRs输入到Excel中
Sub rtpExcel()
    Dim i As Integer
    Dim Irow, Icol As Integer
    Dim Irowcount, Icolcount As Integer
    Dim Fieldlen() '存字段长度值
    Dim Fieldlen1 As Integer
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    
    With rtpRS
   ' .MoveLast
    If .RecordCount < 1 Then
        MsgBox ("Error 没有记录!")
        Exit Sub
    End If

    Irowcount = .RecordCount '记录总数
    Icolcount = .Fields.Count '字段总数

    ReDim Fieldlen(Icolcount)
    .MoveFirst
    For Irow = 1 To Irowcount + 3 '数据开始循环输出的表行开端数
      For Icol = 1 To Icolcount
        Select Case Irow
        Case 1 '在Excel中的第一行加标题
            xlSheet.Cells(Irow, Int(Icolcount / 2)).Value = rtpTitle
        Case 2 '在Excel中的第2行副标题,或日期之类
             xlSheet.Cells(Irow, 1).Value = " 打印日期: " & Format(Date, "yyyy年mm月dd日") & "  " & Time
            xlSheet.Cells(Irow, 1).Font.Size = 10
        Case 3 '在Excel中的第一行加标题
            xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).name
        Case 4 '将数组FIELDLEN()存为第一条记录的字段长

            If IsNull(.Fields(Icol - 1)) = True Then

                Fieldlen(Icol) = LenB(.Fields(Icol - 1).name)

          '如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度

            Else

                Fieldlen(Icol) = LenB(.Fields(Icol - 1))

            End If


            xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)

      'Excel列宽等于字段长

            xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)

      '向Excel的CellS中写入字段值

        Case Else

        If LenB(.Fields(Icol - 1)) > 0 Then

        Fieldlen1 = LenB(.Fields(Icol - 1))
        Else
        End If



            If Fieldlen(Icol) < Fieldlen1 Then

                xlSheet.Columns(Icol).ColumnWidth = Fieldlen1

      '表格列宽等于较长字段长

                Fieldlen(Icol) = Fieldlen1

      '数组Fieldlen(Icol)中存放最大字段长度值

            Else

                xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)

            End If

            xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)

    End Select

    Next

    If Irow > 3 And Not .EOF Then '3为数据开始循环输出的表行开端数

    .MoveNext

    End If

    Next
    With xlSheet
    .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Size = 16
    .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
    .Range(.Cells(1, 1), .Cells(1, Icol - 1)).RowHeight = 26
    .Range(.Cells(3, 1), .Cells(3, Icol - 1)).Font.name = "宋体"
    '.Range(.Cells(3, 1), .Cells(3, Icol - 1)).Font.Color = vbRed
    .Range(.Cells(3, 1), .Cells(3, Icol - 1)).Font.Bold = True
    '.Range(.Cells(3, 1), .Cells(3, Icol - 1)).Borders.Color = vbRed
    .Range(.Cells(3, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous '设表格边框样式
    End With
    
    xlApp.Visible = True '显示表格
   xlApp.ActiveWorkbook.PrintPreview
   xlApp.AlertBeforeOverwriting = False
    'xlBook.Save "f:\test.xls"
    Set xlApp = Nothing '交还控制给Excel

    End With
End Sub

Public Sub Explode(Newform As Form, Increment As Integer)
Dim Count, LeftPoint, TopPoint, nWidth, nHeight As Integer
Dim FormWidth, FormHeight As Integer
Dim Size As RECT
Dim TempDC
GetWindowRect Newform.hwnd, Size
FormWidth = (Size.Right - Size.Left)
FormHeight = (Size.Bottom - Size.Top)
TempDC = GetDC(ByVal 0&)
For Count = 1 To Increment
    nWidth = FormWidth * (Count / Increment)
    nHeight = FormHeight * (Count / Increment)
    LeftPoint = Size.Left + (FormWidth - nWidth) / 2
    TopPoint = Size.Top + (FormHeight - nHeight) / 2
    Rectangle TempDC, LeftPoint, TopPoint, LeftPoint + nWidth, TopPoint + nHeight
Next Count
DeleteDC (TempDC)
End Sub