Отслеживание потери фокуса приложением, сабклассинг.

[Mikle]

Для отслеживания потери фокуса игрой я применил сабклассинг, после сокращений код такой, в модуле:

Код: Выделить всё

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
Public Const WM_ACTIVATE = &H6

Public gWH As Long
Public OldWndProc As Long
Public Paused As Boolean

Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim lReturn As Long

  WindowProc = CallWindowProc(OldWndProc, hwnd, Msg, wParam, lParam)

  If Msg = WM_ACTIVATE Then
    Paused = (wParam And &HFFFF&) = 0
  End If
End Function


В форме:

Код: Выделить всё

Private Sub Form_Load()
  gWH = Me.hwnd
  OldWndProc = SetWindowLong(gWH, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Private Sub Form_Terminate()
  SetWindowLong gWH, GWL_WNDPROC, OldWndProc
End Sub


В зависимости от значения переменной Paused форма сворачивается, а игра становится на паузу.
Это работает, но при отладке, если программа стопарится на какой-нибудь ошибке, то среда VB6 часто вылетает - закрывается без каких-либо сообщений. Когда этот код закоментирован, таких проблем нет. Это я что-то недоделал, или это нормально?

[ger_kar]

Может быть версия VBA6.dll глючная и причина заключается в том, что написал Хакер в этой теме?

[Mikle]

Может быть версия VBA6.dll глючная и причина заключается в том, что написал Хакер в этой теме?

Почитал, что-то близкое, но у меня ещё загадочнее, я локализовал ошибку. Пока в проекте полностью закомментированы все строки, связанные с сабклассингом - проект работает, можно редактировать, но стоит всего лишь снять комментарии с этих строк:

Код: Выделить всё

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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


Всё! Проект при запуске рушится, хотя никаких обращений к этим функциям нет. Если снять комментарии до первого запуска - проект работает, но если после этого что угодно изменить - вылет. Причём по Ctrl+F5 вылет происходит мгновенно. Пробовал добавлять в другие проекты эти строки - никаких проблем.
Вот полный проект, в нём задействована dx9vb.tlb от The trick, её нужно зарегистрировать.

[Jack Ferre]

SetWindowLong и CallWindowProc тут не при чём.

F5-> Esc -> Добавляем Dim crash as long в любое место модуля modUtil.bas -> F5 (Или F8) -> IDE падает.

А на счёт сабклассинга в IDE TrickSubClass. Начиная с версии 2.1 - шикарная вещь.

[ger_kar]

F5-> Esc -> Добавляем Dim crash as long в любое место модуля modUtil.bas -> F5 (Или F8) -> IDE падает.

Есть такое дело, а если те же функции:

Код: Выделить всё

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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 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

То в таком варианте ничего не вылетает.

[Jack Ferre]

То в таком варианте ничего не вылетает.

SetWindowLong и CallWindowProc тут не при чём.

F5-> Esc -> Добавляем Dim crash as long в любое место модуля modUtil.bas -> F5 (Или F8) -> IDE падает.

Это я про то, что любое изменение в модуле modUtil.bas приводит к падению IDE во время не первого запуска.
Как выяснил только что - даже в комментариях.

[ger_kar]

Это все очень странно и загадочно. Такое фиг объяснишь. Прям мистика.

[Jack Ferre]

Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

И далее вычисления с типом Currency
Возможно просто P-Code. Безжалостный и беспощадный. А может и не в этом дело.

Переписал Currency --> LongLong. Ничего не вылетает.

[Mikle]

Currency

Эту часть кода я использую давно, в разных проектах, никогда не было проблем. Да и непонятно, почему вылетает только после редактирования, которое было после запуска.

[The trick]

Странный баг. Даже если вообще ничего не выполнять - полностью закомментить Sub Main то наблюдается тоже самое.
Проблема начинается при компиляции модуля modMath. Что конкретно вызывает ошибку пока не понятно, да и времени особо нет реверсить там без отладочных символов.
Может быть какой-то баг VB6 как например с GradientFill. (попробуй к примеру задекларировать MemCpy в modMath для исправления бага).

[Mikle]

Реально фантастика. Закомментировал всё, связанное с Currency, заменил содержимое функций:

Код: Выделить всё

Dim QT As Double
Public Sub QTimeReset(ByVal Time As Double)
  QT = Timer + Time
End Sub

Public Function QTime() As Double
  QTime = Timer - QT
End Function

Работает, но стоит после запуска даже добавить в конце какой-нибудь строки модуля modUtil пробел, то есть ничего не изменить, как программа крашится при запуске.

попробуй к примеру задекларировать MemCpy в modMath для исправления бага

Сделал - работает, вернул на место QTimer - работает, вернул сабклассинг - работает, вношу изменения в код, перезапускаю - работает... пока не внёс изменения в modMath, похоже, MemCpy утащил проблему за собой.

[The trick]

Сделал - работает, вернул на место QTimer - работает, вернул сабклассинг - работает, вношу изменения в код, перезапускаю - работает... пока не внёс изменения в modMath, похоже, MemCpy утащил проблему за собой.

Не понимаю. Я имею в виду в modUtil - оставь публичную декларацию, а в modMath добавь приватную декларацию MemCpy, а вообще лучше заюзай tlb это и скорость увеличит и размер уменьшит.
Возможно я что-то неверно думаю, но VB6 не очень хорошо дружит с Any. К примеру создай пустой проект с формой и модулем. В модуль добавь следующий код:

Код: Выделить всё

Option Explicit

Public Type GRADIENT_RECT
    upperLeft   As Long
    lowerRight  As Long
End Type

Public Type TRIVERTEX
    x           As Long
    y           As Long
    red         As Integer
    green       As Integer
    blue        As Integer
    alpha       As Integer
End Type

Public Declare Function GradientFill Lib "msimg32" (ByVal hdc As Long, vertex As Any, ByVal dwNumVertex As Long, pMesh As Any, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long

Public Const GRADIENT_FILL_RECT_V   As Long = 1

Public Function GdiGradientRect(ByVal ulIndex As Long, ByVal lrIndex As Long) As GRADIENT_RECT

    GdiGradientRect.lowerRight = ulIndex
    GdiGradientRect.upperLeft = lrIndex
   
End Function

А в форме:

Код: Выделить всё

Option Explicit

Private Sub Form_Load()
    Dim vtx(1)  As TRIVERTEX
    Dim grRect  As GRADIENT_RECT
   
    vtx(0).blue = &HFF00
    vtx(1).x = 200
    vtx(1).y = 200
    vtx(1).red = &HFF00
   
    ' grRect = GdiGradientRect(0, 1)
    ' GradientFill Me.hdc, vtx(0), 2, grRect, 1, GRADIENT_FILL_RECT_V
    ' CRASH!!!
    GradientFill Me.hdc, vtx(0), 2, GdiGradientRect(0, 1), 1, GRADIENT_FILL_RECT_V
   
End Sub

Вот если передавать непосредственно возвращаемое значение - крэш при компиляции, если через переменную - то все ОК. Возможно что статические массивы в каких-то определенных ситуациях ведут себя также.

[Mikle]

Я имею в виду в modUtil - оставь публичную декларацию, а в modMath добавь приватную декларацию MemCpy

Сделал, после запуска добавляю пробел в modMath - и краш. Я даже переименовал в привычное CopyMemory. Сколько уже им пользовался, проблем не было никогда, As Any не вызывало багов.

[Jack Ferre]

02.27.2016. Исправлен баг в функции D3DXMatrixTranspose. Изменены типы указателей на Any в методах IDirect3DDevice9::CreateVertexShader, IDirect3DDevice9::CreatePixelShader, IDirect3DDevice9::SetPixelShaderConstantB, IDirect3DDevice9::SetPixelShaderConstantI, IDirect3DDevice9::SetPixelShaderConstantF, IDirect3DDevice9::SetVertexShaderConstantB, IDirect3DDevice9::SetVertexShaderConstantI, IDirect3DDevice9::SetVertexShaderConstantF

[Mikle]

Эти исправления были сделаны по моей просьбе, в примере исправленная версия.

[Хакер]

Выложили бы проект готовый для воспроизведения бага.

Пойду пока ручками собирать проект.

И да, в отрыве от описываемого странного поведения, вот это:

В форме:

Код: Выделить всё

Private Sub Form_Load()
  gWH = Me.hwnd
  OldWndProc = SetWindowLong(gWH, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Private Sub Form_Terminate()
  SetWindowLong gWH, GWL_WNDPROC, OldWndProc
End Sub


это уже неправильно. Событие Terminate комплементарно событию Initialize, а событию Load комплементарно событие Unload. В данном случае, Terminate — это слишком поздное снятие.

[Хакер]

Такое фиг объяснишь.

По всей видимости, код проекта в какой-то момент портит память, задевая древовидные структуры, олицетворяющие частично распарсенный исходный код. К моменту правки VBA6 пытается перестроить это дерево, а оно повреждено.

Сейчас разберёмся.

[Mikle]

Событие Terminate комплементарно событию Initialize, а событию Load комплементарно событие Unload. В данном случае, Terminate — это слишком поздное снятие.

Понял, исправлю, но, как видишь, это всё под ремарками, а проект падает.

По всей видимости, код проекта в какой-то момент портит память, задевая древовидные структуры, олицетворяющие частично распарсенный исходный код. К моменту правки VBA6 пытается перестроить это дерево, а оно повреждено.

Так он падает даже если полностью заремить содержимое Sub Main, то есть никакой код не выполняется.

[Хакер]

Что я сделал сначала.
Я пошёл в Sub Main и закомментировал там первые строки таким образом:

Код: Выделить всё

Private Sub Main()
  'ShowCursor 0
  Form1.Show
  'QTimeReset 0
  'PhysInit
  'ResetControl
  D3DInit
  'TexInit
  'BallInit
  'CueInit
  'TableInit
  'ShadersInit

Дальше я пошёл в D3Dinit и там в начало вставил такой код:

Код: Выделить всё

Private Sub D3DInit()
    Stop
    End


С таким подходом первый запуск с полной компиляцией работает нормально, правка Declare, второй запуск с полной компиляцией — вылет.

Но если добавить в проект пустой модуль, то вылеты прекращаются.

P.S. Сам проект у меня нормально не работает — традиционно (для твоих 3D-приложений) облом на создании Direct3DDevice.

[Mikle]

Сам проект у меня нормально не работает — традиционно (для твоих 3D-приложений) облом на создании Direct3DDevice.

Отключи MSAA, просто убери строку:

Код: Выделить всё

  d3dpp.MultiSampleType = D3DMULTISAMPLE_4_SAMPLES

И, если не заработает, замени это:

Код: Выделить всё

  Set Dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Form1.hWnd, D3DCREATE_HARDWARE_VERTEXPROCESSING Or D3DCREATE_FPU_PRESERVE, d3dpp)

на это:

Код: Выделить всё

  Set Dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Form1.hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING Or D3DCREATE_FPU_PRESERVE, d3dpp)

[Mikle]

Последние два дня у меня много работы, никак не доберусь до проекта, чтобы удостовериться, но возникло ощущение, что проблема в подключенной .tlb, просто больше нечему вызвать проблему, если весь код закомментирован. И сабклассинг тут просто случайно попался.

[Хакер]

Trick, признавайся, внедрил таки шеллкод в TLB?

[The trick]

Trick, признавайся, внедрил таки шеллкод в TLB?

Так это невозможно в принципе (может я что-то не знаю?).
Этот глюк из-за TLB?
Я просто взял объявления интерфейсов из заголовочных файлов C++ и вручную преобразовывал в формат IDL + добавил для каждого члена описание из MSDN. Может где-то конфликт каких-либо типов?
Мне кажется это все-таки глюк похожий на этот.