Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add language annotation pattern to VB6 #3

Closed
wants to merge 5 commits into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension


Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .github/workflows/ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@ jobs:
bundler-cache: true
- name: Fetch grammar submodules
run: |
git fetch origin master:master v2.0.0:v2.0.0 test/attributes:test/attributes test/master:test/master
git fetch origin master:master
sed -i 's|git@github.com:|https://github.com/|' .gitmodules
git submodule init
git submodule sync --quiet
Expand Down
2 changes: 2 additions & 0 deletions lib/linguist/heuristics.yml
Original file line number Diff line number Diff line change
Expand Up @@ -92,6 +92,8 @@ disambiguations:
pattern: '^[ \t]*#(?i)(?:define|endif|endmacro|ifn?def|include|lang|macro)(?:$|\s)'
- language: BASIC
pattern: '\A\s*\d'
- language: Visual Basic 6.0
pattern: '''@Lang (VB\d|Visual Basic \d)'
- language: VBA
and:
- named_pattern: vb-module
Expand Down
83 changes: 83 additions & 0 deletions samples/Visual Basic 6.0/mHook.bas
Original file line number Diff line number Diff line change
@@ -0,0 +1,83 @@
Attribute VB_Name = "mHook"
'@Lang VB6
Option Explicit

'-- API:

#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As GWL_INDEX) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As GWL_INDEX, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As GWL_INDEX) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As GWL_INDEX, ByVal dwNewLong As Long) As Long
#End If
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)

Private Enum GWL_INDEX
GWL_WNDPROC = (-4)
GWL_HINSTANCE = (-6)
GWL_HWNDPARENT = (-8)
GWL_ID = (-12)
GWL_STYLE = (-16)
GWL_EXSTYLE = (-20)
GWL_USERDATA = (-21)
End Enum

Private Const WM_ACTIVATE As Long = &H6
Private Const WM_MOUSEWHEEL As Long = &H20A

'-- Private variables:

Private m_lpPrevWndProcLems As LongPtr



'========================================================================================
' Methods
'========================================================================================

Public Sub InitializeHook(oForm As Form)

m_lpPrevWndProcLems = SetWindowLong(fLems.hWnd, GWL_WNDPROC, AddressOf pvWindowProcLems)
End Sub

'========================================================================================
' Private
'========================================================================================

Private Sub SendKeysB(ByRef Text As String, Optional ByRef Wait As Boolean)
Static wsh As Object
If wsh Is Nothing Then
Set wsh = CreateObject("WScript.Shell")
End If
wsh.SendKeys Text, Wait
End Sub

Private Function pvWindowProcLems( _
ByVal hwnd As LongPtr, _
ByVal uMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr _
) As LongPtr

Select Case uMsg

Case WM_ACTIVATE

Call mTiming.SetAppActive(CBool(wParam And &HFFFF&))

Case WM_MOUSEWHEEL
Dim noExt As Long
CopyMemory noExt, wParam, 4
If (noExt > 0) Then
'Call VBA.SendKeys("Z")
SendKeysB "Z"
Else
'Call VBA.SendKeys("A")
SendKeysB "A"
End If
End Select

pvWindowProcLems = CallWindowProc(m_lpPrevWndProcLems, hwnd, uMsg, wParam, lParam)
End Function
Loading