module1.bas

来自「星级酒店客房管理系统一套很不错的系统」· BAS 代码 · 共 427 行

Attribute VB_Name = "Module1"
Option Explicit
'取掉窗口关闭按钮API参数
Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long

Public Const MF_BYPOSITION = &H400&
'定义报表全局数据集,然后在需要打印处加入以下语句:
'Set rtpRS = Data1.Recordset
'rtpTitle = "销售报表"
'rtpExcel

Public rtpRS As Recordset
Public rtpTitle As String
'单位信息定义
Public DWMC As String '使用单位名称
Public DWTEL As String
Public DWADD As String
Public DWBANK As String
Public DWBANKNO As String
Public DWWEBSITE As String

Public TongZhi As String
Public BKPicPath As String
Public USER_ID As String
Public RoomForm_Type As String
Public RoomNO As String
Public Room_Rate As Currency
Public Room_Statu As String
Public Room_Type As String
Public Room_SaleType As String
Public Room_Update As Boolean
Public Room_Share_Type As String
Public Room_Use_Type As String
Public Half_time As String
Public Half_times As String
Public Table_Name As String
Public Table_SetType As String
Public Report_Type As String
Public RoomFlag As Boolean

Public PRN_Name As String
Public PRN_Sex As String
Public PRN_Room As String
Public PRN_EnglishName As String
Public PRN_Date1 As String
Public PRN_Date2 As String
Public PRN_CusType As String
Public PRN_AccountRec As String
Public PRN_Days As String
Public PRN_STR(147) As String
Public PRN_SUM(12) As String

'杂项参数
Public QuickMenu As Boolean

'LOAD_STATU房态图装入是“使用”&“显示”
Public Load_Statu As String
Public FB_table2 As String
Public FB_SumTable As String
Public CUR_Statu As String
Public GG_settype As String

Public US_Field As String
Public System_Date As String
Public System_Statu As String

Public Account_ID As String
Public QAccount_ID As String
Public Query_Type As String
Public Query_Type2 As String
Public Registration_Type As String
Public Registration_Type2 As String

Public Paper_W As Single
Public Paper_H As Single
Public BB_title As String
Public DATA_SERVER As String
Public BB_type As String

Public NET_pass As Boolean
Public FP_ZDLX As String

Public CKD As String

Public My_USERID As String
Public My_PASSWORD As String
Public My_DATASOURCE As String
Public My_INITIALCATALOG As String
Public BK_PROVIDER As String
Public BQ_lb As String

Public TableName(22) As String

Public PASSed1 As Boolean
Public CzyName As String
Public CzyType As String
Public CzyPassWord As String

Public Const FO_MOVE As Long = &H1
Public Const FO_COPY As Long = &H2
Public Const FO_DELETE As Long = &H3
Public Const FO_RENAME As Long = &H4
Public Const FOF_MULTIDESTFILES As Long = &H1
Public Const FOF_CONFIRMMOUSE As Long = &H2
Public Const FOF_SILENT As Long = &H4
Public Const FOF_RENAMEONCOLLISION As Long = &H8
Public Const FOF_NOCONFIRMATION As Long = &H10
Public Const FOF_WANTMAPPINGHANDLE As Long = &H20
Public Const FOF_CREATEPROGRESSDLG As Long = &H0
Public Const FOF_ALLOWUNDO As Long = &H40
Public Const FOF_FILESONLY As Long = &H80
Public Const FOF_SIMPLEPROGRESS As Long = &H100
Public Const FOF_NOCONFIRMMKDIR As Long = &H200

'定义连接字符串
Public My_PROVIDER As String
Public Sub Enter(KeyCode As Integer)
  If KeyCode = vbKeyReturn Then
     SendKeys "{Tab}"
  End If
End Sub
'定义窗口位置参数
Type SHFILEOPSTRUCT
     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Long
     fAnyOperationsAborted As Long
     hNameMappings As Long
     lpszProgressTitle As String
End Type
'取掉窗口关闭按钮函数
Public Sub DisableX(Frm As Form)
    Dim hMenu As Long, nCount As Long
    hMenu = GetSystemMenu(Frm.hwnd, 0)
    nCount = GetMenuItemCount(hMenu)
    Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION)
    DrawMenuBar Frm.hwnd
End Sub
Public Function Cmoney(jiner0 As Currency)
 Dim mone0 As String
 Dim mone1 As String
 Dim ii As Integer
 Dim monelen1 As Integer
 Dim rmb As String
 Dim cmone0 As String
 Dim numb0 As String
 
 mone0 = Format(jiner0, "00000.00")
 ii = 1
 mone1 = Mid(mone0, 1, 5) + Mid(mone0, 7, 2)
 mone1 = Trim(mone1)
 monelen1 = Len(mone1)
 Select Case monelen1
      Case 1
           rmb = "分"
      Case 2
           rmb = "角分"
      Case 3
           rmb = "元角分"
      Case 4
           rmb = "拾元角分"
      Case 5
           rmb = "佰拾元角分"
      Case 6
           rmb = "仟佰拾元角分"
      Case 7
           rmb = "万仟佰拾元角分"
 End Select
 cmone0 = ""
 While ii < Len(mone1) + 1
      numb0 = Mid(mone1, ii, 1)
      Select Case numb0
           Case " "
                cmone0 = cmone0 & "零"
           Case "0"
                cmone0 = cmone0 & "零"
           Case "1"
                cmone0 = cmone0 & "壹"
           Case "2"
                cmone0 = cmone0 & "贰"
           Case "3"
                cmone0 = cmone0 & "叁"
           Case "4"
                cmone0 = cmone0 & "肆"
           Case "5"
                cmone0 = cmone0 & "伍"
           Case "6"
                cmone0 = cmone0 & "陆"
           Case "7"
                cmone0 = cmone0 & "柒"
           Case "8"
                cmone0 = cmone0 & "捌"
           Case "9"
                cmone0 = cmone0 & "玖"
      End Select
      cmone0 = cmone0 & Mid(rmb, (ii - 1) * 1 + 1, 1)
      ii = ii + 1
 Wend
 Cmoney = cmone0
End Function
Public Function int_Month(month1, month2) As Integer
    Dim I_year, I_month As Integer
    I_year = CInt(Left(month2, 4)) - CInt(Left(month1, 4))
    I_month = CInt(Right(month2, 2)) - CInt(Right(month1, 2))
    int_Month = I_year * 12 + I_month
End Function
Public Function Js_Month(month1, JS_para As Integer) As String
    Dim I_year, I_month As Long
    
    I_year = CInt(Left(month1, 4))
    I_month = CInt(Right(month1, 2))
    If (I_year * 12 + I_month + JS_para) Mod 12 = 0 Then
        Js_Month = CStr(Int((I_year * 12 + I_month + JS_para) / 12) - 1) & ".12"
    Else
        Js_Month = CStr(Int((I_year * 12 + I_month + JS_para) / 12)) & "." & Format((I_year * 12 + I_month + JS_para) Mod 12, "00")
    End If
End Function
Public Sub XG_weidl()
        F_addr.Locked = True
        f_addrno.Locked = True
        f_code.Locked = True
        f_nodeno.Locked = True
        F_tel.Locked = True
        f_grou.Locked = True
End Sub
Sub SetGridColor(GRID As Control, row_col As Boolean, color1 As Long, color2 As Long)
Dim i As Integer
Dim j As Integer
Dim K As Long
 GRID.Redraw = False
 GRID.BackColorBkg = &H808080
 GRID.BackColorFixed = &HC0C0C0
 
If row_col Then
 For j = GRID.FixedRows To GRID.Rows - 1
     If K = color2 Then
        K = color1
     Else
        K = color2
     End If
 For i = GRID.FixedCols To GRID.Cols - 1
      GRID.Row = j: GRID.Col = i
      GRID.CellBackColor = K
      GRID.CellForeColor = &H80000008
 Next
Next

GRID.Row = 0
For i = 0 To GRID.Cols - 1
 GRID.Col = i
 GRID.CellAlignment = 4
Next
GRID.Redraw = True
Else
'*****
 For j = GRID.FixedCols To GRID.Cols - 1
     If K = color2 Then
        K = color1
     Else
        K = color2
     End If
 
    For i = GRID.FixedRows To GRID.Rows - 1
      GRID.Col = j: GRID.Row = i
      GRID.CellBackColor = K
      GRID.CellForeColor = &H80000008
    Next
Next

GRID.Col = 0
For i = 0 To GRID.Rows - 1
 GRID.Row = i
 GRID.CellAlignment = 4
Next
GRID.Redraw = True
End If
End Sub
Public Sub query(sql As String)
    Dim i As Integer
    Dim ii As Integer
    Set rsdyn = New Recordset
    rsdyn.CursorLocation = adUseClient
    rsdyn.Open sql, conndyn, adOpenForwardOnly, adLockReadOnly
    Set frmdynareport.dgsource.DataSource = rsdyn
    frmdynareport.dgsource.Refresh
    
    '取得记录哉数量，并把哉标题存入到数组里
    ii = rsdyn.Fields.Count
    '根据repflag判断是否能使用VB报表功能
    If ii > repfields Then
        repflag = True
    Else
     repflag = False
    End If
    ReDim arrrep(ii) As String
    ReDim widrep(ii) As Integer
    
    For i = 0 To ii - 1
    arrrep(i) = rsdyn.Fields(i).Name
    widrep(i) = Len(rsdyn.Fields(i).Name) + 20
    Next
    '根据字段宽度取得记录集标题宽度
    frmdynareport.lblstat.Caption = "共找到 (" & rsdyn.RecordCount & ")" & " 条记录！ "
    If rsdyn.RecordCount = 0 Then vexcel = True '是否能输出报表的标识
End Sub

'将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 = 0 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(1, Int(Icolcount / 2)).Value = rtpTitle
    Case 2 '在Excel中的第2行副标题,或日期之类
     xlSheet.Cells(2, 1).Value = " 日期: " & Format(Date, "yyyy年mm月dd日")
    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 Then

    If Not .EOF Then .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 '显示表格
    xlBook.Save '"保存"

    Set xlApp = Nothing '交还控制给Excel
    End With
End Sub