module1.bas

小型酒店管理系统

Attribute VB_Name = "Module1"
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)
Public Const STRBGNAME As String = "演示版本"

Sub Main()
    Load frmSplash
    frmSplash.Show vbModal
    Load frmLogin
    frmLogin.Show

End Sub
Public Function SUMDM(S1 As Double) As String
    If S1 = 0 Then Exit Function
    If S1 < 0 Then S7 = "(负)" Else S7 = ""
    S2 = Format(Abs(S1), "###0.00")
    If Len(S2) > 16 Then MsgBox "数据溢出", vbCritical, "错误信息"
    S4 = Trim(S2)
    For S3 = 1 To Len(S2)
        Select Case left(S4, 1)
            Case Is = 0
                S5 = "零"
            Case 1
                S5 = "壹"
            Case 2
                S5 = "贰"
            Case 3
                S5 = "叁"
            Case 4
                S5 = "肆"
            Case 5
                S5 = "伍"
            Case 6
                S5 = "陆"
            Case 7
                S5 = "柒"
            Case 8
                S5 = "捌"
            Case 9
                S5 = "玖"
            Case "."
                S5 = ""
        End Select
        If S5 = "零" Then
           If Len(S4) = 12 Then
              S5 = "亿"
              Else
                If Len(S4) = 8 Then
                   S5 = "万"
                   Else
                     If Len(S4) = 4 Then
                        If S7 = "" Then
                           S5 = ""
                           Else
                             S5 = "元"
                        End If
                     End If
                End If
           End If
           S6 = ""
           Else
             Select Case Len(S4)
                Case 1
                    S6 = "分"
                Case 2
                    S6 = "角"
                Case 3
                    S6 = ""
                Case 4
                    S6 = "元"
                Case 5
                    S6 = "拾"
                Case 6
                    S6 = "佰"
                Case 7
                    S6 = "仟"
                Case 8
                    S6 = "万"
                Case 9
                    S6 = "拾"
                Case 10
                    S6 = "佰"
                Case 11
                    S6 = "仟"
                Case 12
                    S6 = "亿"
                Case 13
                    S6 = "十"
                Case 14
                    S6 = "佰"
                Case 15
                    S6 = "仟"
                Case 16
                    S6 = "万"
            End Select
        End If
        S4 = right(S4, Len(S4) - 1)
        If S5 = "零" Then
           If left(S4, 1) = "" Then
              S7 = S7 + "整"
              Else
                If left(S4, 1) <> "0" Then
                   S7 = S7 + S5 + S6
                End If
           End If
           Else
             S7 = S7 + S5 + S6
        End If
    Next S3
    SUMDM = S7
End Function
Function PYM(YW As String)
    Dim HZ1 As String
    Dim HZPY As String
    Dim STRVALID As String
    Dim DATJDGL As Database
    Dim RECHZK As Recordset
    
    STRVALID = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    
    Set DATJDGL = OpenDatabase(App.Path & "\DATA\JDGL.MDB")
    Set RECHZK = DATJDGL.OpenRecordset("HZ", dbOpenDynaset)

    While Len(YW) > 0
        HZ1 = Chr(Asc(YW))
        RECHZK.FindFirst ("HZ='" & HZ1 & "'")
        If Not RECHZK.NoMatch Then
           If IsNull(RECHZK("FPY")) Then
              HZPY = InputBox("请输入汉字“" & RECHZK("HZ") & "”读音的声母:", "加注拼音")
              If Len(HZPY) = 0 Then HZPY = "" Else HZPY = Chr(Asc(HZPY))
              If InStr(STRVALID, UCase(HZPY)) = 0 Then HZPY = ""
              While Len(HZPY) = 0
                    HZPY = InputBox("请输入汉字“" & RECHZK("HZ") & "”读音的声母:", "加注拼音")
                    If Len(HZPY) = 0 Then HZPY = "" Else HZPY = Chr(Asc(HZPY))
                    If InStr(STRVALID, UCase(HZPY)) = 0 Then HZPY = ""
              Wend
              PYM = PYM + HZPY
              RECHZK.Edit
              RECHZK("FPY") = HZPY
              RECHZK.Update
              Else
                PYM = PYM + RECHZK("FPY")
           End If
           Else
             PYM = PYM + HZ1
        End If
        YW = right(YW, Len(YW) - Len(HZ1))
    Wend
    RECHZK.Close
    DATJDGL.Close
    Set RECHZK = Nothing
    Set DATJDGL = Nothing
    
End Function

Sub Gradient(TheObject As Object, Redval&, Greenval&, Blueval&, TopToBottom As Boolean)
    'TheObject can be any object that supports the Line method (like forms and pictures).
    'Redval, Greenval, and Blueval are the Red, Green, and Blue starting values from 0 to 255.
    'TopToBottom determines whether the gradient will draw down or up.
    Dim Step%, Reps%, FillTop%, FillLeft%, FillRight%, FillBottom%, HColor$
    'This will create 63 steps in the gradient. This looks smooth on 16-bit and 24-bit color.
    'You can change this, but be careful. You can do some strange-looking stuff with it...
    Step = (TheObject.Height / 63)
    'This tells it whether to start on the top or the bottom and adjusts variables accordingly.
    If TopToBottom = True Then FillTop = 0 Else FillTop = TheObject.Height - Step
    FillLeft = 0
    FillRight = TheObject.Width
    FillBottom = FillTop + Step
    'If you changed the number of steps, change the number of reps to match it.
    'If you don't, the gradient will look all funny.
    For Reps = 1 To 63
        'This draws the colored bar.
        TheObject.Line (FillLeft, FillTop)-(FillRight, FillBottom), RGB(Redval, Greenval, Blueval), BF
        'This decreases the RGB values to darken the color.
        'Lower the value for "squished" gradients. Raise it for incomplete gradients.
        'Also, if you change the number of steps, you will need to change this number.
        Redval = Redval - 4
        Greenval = Greenval - 4
        Blueval = Blueval - 4
        'This prevents the RGB values from becoming negative, which causes a runtime error.
        If Redval <= 0 Then Redval = 0
        If Greenval <= 0 Then Greenval = 0
        If Blueval <= 0 Then Blueval = 0
        'More top or bottom stuff; Moves to next bar.
        If TopToBottom = True Then FillTop = FillBottom Else FillTop = FillTop - Step
        FillBottom = FillTop + Step
    Next
End Sub