modfx.bas

收银机库存销售管理程序

' MACOS Button
Function MacButton(xCaption As String, xDestination As PictureBox, _
                    nTop As Integer, nLeft As Integer, nWidth As Integer, _
                    nHeight As Integer, xSource As PictureBox, _
                    xTop As Integer, xLeft As Integer, xType As Integer)
    Call BitBlt(xDestination.hDC, nTop, nLeft, nWidth, nHeight, xSource.hDC, xTop, xLeft, SRCCOPY)
    xDestination.Refresh
    xDestination.FontBold = False
    xDestination.FontSize = 9
    xDestination.CurrentX = 117
    If xType = 1 Then
        xDestination.Font = "System"
        xDestination.CurrentY = 159
    ElseIf xType = 2 Then
        xDestination.Font = "System"
        xDestination.CurrentY = 112
    ElseIf xType = 3 Then
        xDestination.Font = "Wingdings 3"
        xDestination.CurrentY = 40
    End If
    xDestination.Print xCaption
End Function

' EXIT WINDOWS FUNCTION
Function DoExitWindows()
    On Error Resume Next
    Dim RetVal As Integer
    RetVal = ExitWindows(EW_EXITWINDOWS, 0)
End Function

' Drag Form Function
Function DragForm(frm As Form)
  Dim ret As Long
  ret = ReleaseCapture()
  ret = SendMessage(frm.hwnd, WM_NCLBUTTONDOWN, 2&, 0&)
End Function

' 3D FORM SETTINGS
Function ColForm(Obj As Object, r%, G%, B%, Step%)
    Dim R1%, G1%, B1%, R2%, G2%, B2%
    Obj.ScaleMode = 3
    Obj.AutoRedraw = True
    Obj.BackColor = RGB(r%, G%, B%)
    R1% = r% + Step%: If R1% > 255 Then R1% = 255
    G1% = G% + Step%: If G1% > 255 Then G1% = 255
    B1% = B% + Step%: If B1% > 255 Then B1% = 255
    R2% = r% - Step%: If R2% < 0 Then R2% = 0
    G2% = G% - Step%: If G2% < 0 Then G2% = 0
    B2% = B% - Step%: If B2% < 0 Then B2% = 0
    Obj.Line (2, 2)-(Obj.ScaleWidth - 2, Obj.ScaleHeight - 2), RGB(R1%, G1%, B1%), B
    Obj.Line (Obj.ScaleWidth - 2, 2)-(Obj.ScaleWidth - 2, Obj.ScaleHeight - 1), RGB(R2%, G2%, B2%)
    Obj.Line (1, Obj.ScaleHeight - 2)-(Obj.ScaleWidth - 2, Obj.ScaleHeight - 2), RGB(R2%, G2%, B2%)
    Obj.Line (5, 5)-(Obj.ScaleWidth - 5, Obj.ScaleHeight - 5), RGB(R2%, G2%, B2%), B
    Obj.Line (Obj.ScaleWidth - 5, 6)-(Obj.ScaleWidth - 5, Obj.ScaleHeight - 4), RGB(R1%, G1%, B1%)
    Obj.Line (5, Obj.ScaleHeight - 5)-(Obj.ScaleWidth - 5, Obj.ScaleHeight - 5), RGB(R1%, G1%, B1%)
End Function

' SET FORM ON TOP
Public Sub SetFormOnTop(myForm As Object)
     SetWindowPos myForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

' FOR EXIT GUI EFFECTS
Public Sub ExitFx(frm As Form)
    On Error Resume Next
    Dim GotoVal, GoInto
    GotoVal = frm.Height / 2
    For GoInto = 1 To GotoVal
        DoEvents
        frm.Height = frm.Height - 100
        frm.Top = (Screen.Height - frm.Height) \ 2
        If frm.Height <= 500 Then Exit For
            Next GoInto
horiz:
    frm.Height = 100
    GotoVal = frm.Width / 2
        For GoInto = 1 To GotoVal
            DoEvents
            frm.Width = frm.Width - 100
            frm.Left = (Screen.Width - frm.Width) \ 2
        If frm.Width <= 20 Then Exit For
            Next GoInto
End Sub

' FOR UNLOADING ALL FORMS
Public Sub UnloadAllForms(Optional sFormName As String = "")
    Dim Form As Form
    For Each Form In Forms
        If Form.Name <> sFormName Then
            Unload Form
            Set Form = Nothing
        End If
    Next Form
End Sub

' FOR MINIMIZING ALL FORMS
Public Sub MinimizeAllForms()
    Dim objTemp As Object
        For Each objTemp In Forms
            objTemp.WindowState = 1
        Next
End Sub

' FOR HIDING CHILD FORMS
Public Sub HideAllForms()
    Dim objTemp As Object
        For Each objTemp In Forms
            objTemp.Hide
        Next
End Sub
' SYNTAX: HideChildForms

' FOR INI SETTINGS
Function ReadINI(Section, Keyname, filename As String) As String
    Dim sRet As String
    sRet = String(255, Chr(0))
    ReadINI = Left(sRet, GetPrivateProfileString(Section, ByVal Keyname, "", sRet, Len(sRet), filename))
End Function
Function WriteINI(sSection As String, sKeyName As String, sNewString As String, sFileName) As Integer
    Dim r
    r = WritePrivateProfileString(sSection, sKeyName, sNewString, sFileName)
End Function

' FOR RESOLUTION VERIFIER
Function IsResolution(Width As Integer, Height As Integer) As Boolean
    If (Screen.Width / Screen.TwipsPerPixelX = Width) And (Screen.Height / Screen.TwipsPerPixelY = Height) Then
        IsResolution = True
    Else
        IsResolution = False
    End If
End Function

' FOR RESOLUTION CHANGER
Function ChangeRes(Width As Single, Height As Single, BPP As Integer) As Integer
    On Error GoTo ERROR_HANDLER
    Dim DevM As DEVMODE, i As Integer, ReturnVal As Boolean, _
    RetValue, OldWidth As Single, OldHeight As Single, _
    OldBPP As Integer
    Call EnumDisplaySettings(0&, -1, DevM)
    OldWidth = DevM.dmPelsWidth
    OldHeight = DevM.dmPelsHeight
    OldBPP = DevM.dmBitsPerPel
    i = 0
    Do
        ReturnVal = EnumDisplaySettings(0&, i, DevM)
        i = i + 1
    Loop Until (ReturnVal = False)
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
    DevM.dmPelsWidth = Width
    DevM.dmPelsHeight = Height
    DevM.dmBitsPerPel = BPP
    Call ChangeDisplaySettings(DevM, 1)
    If RetValue = vbCancel Then
        DevM.dmPelsWidth = OldWidth
        DevM.dmPelsHeight = OldHeight
        DevM.dmBitsPerPel = OldBPP
        Call ChangeDisplaySettings(DevM, 1)
        ChangeRes = 0
    Else
        ChangeRes = 1
    End If
    Exit Function
ERROR_HANDLER:
    ChangeRes = 0
End Function

' TO DISABLE/ENABLE CTRL-ALT-DELETE
Function DisableCtrlAltDelete(bDisabled As Boolean)
    Dim X As Long
    X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Function
        
' DISABLE RIGHT MOUSE CLICK
Public Function MouseHookProc(ByVal nCode As Long, ByVal wParam As Long, mhs As MOUSEHOOKSTRUCT) As Long
    If (nCode >= 0 And wParam = WM_RBUTTONUP) Then
        Dim sClassName As String
        Dim sTestClass As String
        sTestClass = "HTML_Internet Explorer"
        sClassName = String$(256, 0)
        If GetClassName(mhs.hwnd, sClassName, Len(sClassName)) > 0 Then
            If Left$(sClassName, Len(sTestClass)) = sTestClass Then
                MouseHookProc = 1
                Exit Function
            End If
        End If
    End If
    MouseHookProc = CallNextHookEx(l_hMouseHook, nCode, wParam, mhs)
End Function
Public Sub BeginRightMouseTrap()
    l_hMouseHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, GetCurrentThreadId)
End Sub
Public Sub EndRightMouseTrap()
    UnhookWindowsHookEx l_hMouseHook
End Sub