mod2.bas

这是个库存管理系统

Attribute VB_Name = "Module1"
Option Explicit

'----------------------------------------------------------
'Note:
'   The HiWord & LoWord functions are from
'   the book Hardcore Visual Basic by
'   B.Mckinney
'----------------------------------------------------------



'----------------------------------------------------------
'API Constants
'----------------------------------------------------------
Public Const GWL_WNDPROC = (-4)
Public Const WM_DISPLAYCHANGE = &H7E

Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Public Const DISP_CHANGE_FAILED = -1
Public Const DISP_CHANGE_BADMODE = -2
Public Const DISP_CHANGE_NOTUPDATED = -3
Public Const DISP_CHANGE_BADFLAGS = -4
Public Const DISP_CHANGE_BADPARAM = -5
Public Const CDS_UPDATEREGISTRY = 1
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSHEIGHT = &H100000
Public Const DM_PELSWIDTH = &H80000


Public Type DevMode
    dmDeviceName As String * 32
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * 32
    dmLogPixels As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
'#if(WINVER >= 0x0400)
    dmICMMethod As Long         ' Windows 95 only
    dmICMIntent As Long         ' Windows 95 only
    dmMediaType As Long         ' Windows 95 only
    dmDitherType As Long        ' Windows 95 only
    dmICCManufacturer As Long   ' Windows 95 only
    dmICCModel As Long          ' Windows 95 only
    dmPanningWidth As Long  ' Windows 95 only
    dmPanningHeight As Long ' Windows 95 only
'#endif /* WINVER >= 0x0400 */
End Type


'----------------------------------------------------------
'API Funcitons
'----------------------------------------------------------
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Function ChangeDisplaySettings Lib "user32" _
    Alias "ChangeDisplaySettingsA" _
    (lpDevMode As DevMode, ByVal dwFlags As Long) As Long

Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _
    (ByVal lpszDeviceName As String, ByVal iModeNum As Long, _
    lpDevMode As DevMode) As Long
    
'----------------------------------------------------------
'Global Var
'----------------------------------------------------------
Public lPreWndProc As Long


Public Type TLoHiLong
    lo As Integer
    hi As Integer
End Type

Public Type TAllLong
    all As Long
End Type


'----------------------------------------------------------
'Code for Subclassing
'----------------------------------------------------------
Public Function MyWndProc _
    (ByVal hwnd As Long, _
    ByVal lMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
    If lMsg = WM_DISPLAYCHANGE Then
'        Debug.Print "DisplayChange"
'        Debug.Print "BitsPerPel: ", wParam
'        Debug.Print "lParam: ", lParam
'        Debug.Print "loword of lParam: ", LoWord(lParam)
'        Debug.Print "HiWord of lParam: ", HiWord(lParam)
    End If
    
    MyWndProc = CallWindowProc(lPreWndProc, hwnd, lMsg, wParam, lParam)

End Function

Public Function LoWord(dw As Long) As Integer
    Dim lohi As TLoHiLong
    Dim all As TAllLong
    all.all = dw
    LSet lohi = all
    LoWord = lohi.lo
End Function

Public Function HiWord(dw As Long) As Integer
    Dim lohi As TLoHiLong
    Dim all As TAllLong
    all.all = dw
    LSet lohi = all
    HiWord = lohi.hi
End Function