module2.bas

運動會或各式活動秩序冊製作及檢錄表製作管理系統

Attribute VB_Name = "Module2"
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?996-2000 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' You are free to use this code within your own applications,
' but you are expressly forbidden from selling or otherwise
' distributing this source code without prior written consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Const GWL_WNDPROC As Long = (-4)
Public Const WM_SIZE As Long = &H5
Public Const WM_PAINT As Long = &HF
Public Const CB_DELETESTRING As Long = &H144
Public Const CB_RESETCONTENT As Long = &H14B
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202


Public Declare Function SendMessage _
   Lib "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, ByVal wMsg As Long, _
   ByVal wParam As Long, lParam As Any) As Long
  
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long) As Long
    
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
    
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
Private 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 Const GWL_WNDPROC = -4

Private Const WM_MOUSEWHEEL = &H20A

Private Const WHEEL_DELTA = 120
Private Const WHEEL_PAGESCROLL = &HFFFFFFFF

Public Const SPI_GETWHEELSCROLLLINES = 104

Public Const SM_MOUSEWHEELPRESENT = 75

Private Const MK_CONTROL = &H8          'Control key
Private Const MK_SHIFT = &H4            'Shift key
Private Const MK_LBUTTON = &H202        'Left mouse button
Private Const MK_MBUTTON = &H10         'Middle mouse button
Private Const MK_RBUTTON = &H2          'Right mouse button
Private Const MK_XBUTTON1 = &H20        'First X button; Windows 2000/XP only
Private Const MK_XBUTTON2 = &H40        'Second X button; Windows 2000/XP only

Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Const MOUSEEVENTF_MIDDLEUP = &H40
Const MOUSEEVENTF_MOVE = &H1
Const MOUSEEVENTF_ABSOLUTE = &H8000
Const MOUSEEVENTF_RIGHTDOWN = &H8
Const MOUSEEVENTF_RIGHTUP = &H10


    ' store a pointer to the form object
    ' which is set via ObjPtr
Public lpFormObj As Long

   
Public Sub Hook1(nForm As Form)

    If nForm.defWinProc = 0 Then
       
      nForm.defWinProc = SetWindowLong(nForm.hWndFlex, _
                                 GWL_WNDPROC, _
                                 AddressOf WindowProc1)
      
    End If
    
End Sub

Public Sub Unhook1(nForm As Form)
    
   If nForm.defWinProc = 0 Then

      Call SetWindowLong(nForm.hWndFlex, _
                         GWL_WNDPROC, _
                         nForm.defWinProc)
      nForm.defWinProc = 0

   End If
    
End Sub

Function WindowProc1(ByVal hwnd As Long, ByVal uMsg As Long, _
                    ByVal wParam As Long, ByVal lParam As Long) As Long
   
   WindowProc1 = CallWindowProc(Form1.defWinProc, hwnd, uMsg, wParam, lParam)

   
   Select Case uMsg
   
      'Case WM_SIZE, WM_PAINT
      Case WM_SIZE
         'If Form1.MSFlexGrid1(0).Row < 1 Then
         
            With Form1
               .T1(0).Width = .MSFlexGrid1(0).CellWidth
               .T1(0).Left = .MSFlexGrid1(0).CellLeft + .MSFlexGrid1(0).Left
               .T1(0).Top = .MSFlexGrid1(0).CellTop + .MSFlexGrid1(0).Top
            End With
         'End If
      Case WM_PAINT
          Form1.Refresh
      Case WM_LBUTTONDOWN
         'If Form1.MSFlexGrid1(0).Row < 1 Then
             With Form1
             .T1(0).Width = .MSFlexGrid1(0).CellWidth
             .T1(0).Left = .MSFlexGrid1(0).CellLeft + .MSFlexGrid1(0).Left
             .T1(0).Top = .MSFlexGrid1(0).CellTop + .MSFlexGrid1(0).Top
             '.Visible = True
             End With
      Case WM_MOUSEWHEEL
           Screen.ActiveForm.Caption = "MouseWheel to row=" + CStr(Form1.MSFlexGrid1(0).Row)
           ' ##### Button/key pressed #####
           Select Case LoWord(wParam)
            
              Case MK_XBUTTON1
              Case MK_LBUTTON
              Case MK_MBUTTON
              Case MK_RBUTTON
              Case MK_XBUTTON2
           End Select
           
           'If TypeOf Form1.ActiveControl Is MSFlexGrid Then
              ' ##### Scroll direction #####
              If (HiWord(wParam) / WHEEL_DELTA) < 0 Then
                  'Scrolling down
                  'Debug.Print "Down"
                
    
                    ' instantiate the pointer we have to the form
                    
                  ' call the method
                  'Screen.ActiveForm.ScrollDown
   
                
               Else
                  'Scrolling up
                  'Debug.Print "UP"
                
    
                    ' instantiate the pointer we have to the form
                  'Set objForm = PtrToForm(lpFormObj)
                  'call the method
                  Screen.ActiveForm.ScrollUp
                  ' destroy the reference
                  'Set objForm = Nothing
                
                
               End If
           
           
         'End If
         'With Form1.MSFlexGrid1(0)
      
          '  If .Col > 0 Then
               
           '    Form1.T1(0).Visible = False
               'Form1.T1(0).Text = ""
               'Form1.FillComboData .Col
            '   Form1.T1(0).Text = .Text
            '   Form1.T1(0).Visible = True
            '   Form1.T1(0).SetFocus
            'End If
   
         'End With
         
      'Case Else
      
   End Select
   

End Function


   
Public Function HiWord(dw As Long) As Integer
    If dw And &H80000000 Then
        HiWord = (dw \ 65535) - 1
    Else
        HiWord = dw \ 65535
    End If
End Function

Public Function LoWord(dw As Long) As Integer
    If dw And &H8000& Then
        LoWord = &H8000 Or (dw And &H7FFF&)
    Else
        LoWord = dw And &HFFFF&
    End If
End Function

'//--[PtrToForm]--------------------------------//
'
'  Creates a dummy object from an ObjPtr
'
'Public Function PtrToForm(ByVal lPtr As Long) As Form1
'Dim obj As Form1
    ' instantiate the illegal referece
'    CopyMemory obj, lPtr, 4
'    Set PtrToForm = obj
'    CopyMemory obj, 0&, 4
'End Function