Keskustelu: Ohjelmointikysymykset: VBA: Moniajo-oppaasta

JoreSoft [16.02.2008 12:35:48]

Moi =)
tässä osoitteessa on esimerkki, kuinka voidaan tehdä moniajoa.
https://www.ohjelmointiputka.net/koodivinkit/24868-vb6-pelin-fps-n-hallinta-tapahtumien-moniajo

' sisäisen koodin hallinta
    Case TICK_INTERNAL
        ' tänne voi kirjoittaa esim.:
        ' - ammusten ja pelaajien liikuttelun
        ' - törmäysten tunnistamisen
        ' - näppäimistön ja hiiren lukemisen

Kysymys kuuluukin, kuinka hiiri- ja näppäimistöä luetaan ilman normaaleja MouseClick yms.

' nämä kutsut ovat parempaa DoEventsin hallintaa varten
' mitä sitä turhaan hidasta DoEventsiä kutsumaan, jos sille ei ole tarvetta...
Public Const QS_KEY = &H1&
Public Const QS_MOUSEMOVE = &H2&
Public Const QS_MOUSEBUTTON = &H4&
Public Const QS_POSTMESSAGE = &H8&
Public Const QS_TIMER = &H10&
Public Const QS_PAINT = &H20&
Public Const QS_SENDMESSAGE = &H40&
Public Const QS_HOTKEY = &H80&
Public Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Public Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Public Const QS_INPUT = (QS_MOUSE Or QS_KEY)
Public Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)

Public Declare Function GetQueueStatus Lib "user32" (ByVal qsFlags As Long) As Long

Tässä mainitaan mahdollisuudesta käyttää GetQueueStatus yms API-kutsuja.
Kuinka tämä siis toimii käytännössä?

Ja hyvää talvilomaa =)

neau33 [02.03.2008 18:40:10]

Moikka JoreSoft!

esim. näin "hiiri- ja näppäimistöä luetaan ilman normaaleja MouseClick yms."
(täysin ilman DoEvents-funktion apua ei kyllä pitkälle pärjää...)
Lisää vielä moduuliin...(jos ei jo ole...)

Public Type POINT_API
 x As Long
 y As Long
End Type
Public Declare Function GetCursorPos Lib "user32.dll" (  _
lpPoint As POINT_API) As Long

'formille: labelli
Private Sub Form_Paint()
  MainLuuppi
End Sub

Sub MainLuuppi()

  Dim koordinaatti As POINT_API
  Dim sijainti As Long

  Do: DoEvents
  If GetQueueStatus(QS_ALLINPUT) Then

    Label1.Caption = GetQueueStatus(QS_ALLINPUT)
    sijainti = GetCursorPos(koordinaatti)
    If Label1.Caption = 262144 And _
    koordinaatti.x * Screen.TwipsPerPixelX > _
    Me.Left + Me.Label1.Left And _
    koordinaatti.x * Screen.TwipsPerPixelX < _
    Me.Left + Me.Label1.Left + Me.Label1.Width And _
    koordinaatti.y * Screen.TwipsPerPixelY > _
    Me.Top + Me.Label1.Top + Me.Label1.Height And _
    koordinaatti.y * Screen.TwipsPerPixelY < _
    Me.Top + Me.Label1.Top + (Me.Label1.Height * 2) _
    Then Exit Do
    'koordinaattien suhde laatikkoon on metsikössä,
    'jutska olis skaalattava SYSTEM_METRICS muotoon...
    '(mutta riittää testaamiseen , en jaksa vääntää)
  End If
  Loop: End

End Sub

neau33 [03.03.2008 02:49:10]

Heippa taas!

oheinen esimerkki soveltuu ehkä paremmin testaamiseen...

'formille pari labellia...
Private Sub Form_Activate()
  MainLuuppi
End Sub

Sub MainLuuppi()

  Dim koordinaatti As POINT_API
  Dim sijainti As Long
  Do: DoEvents
    If GetQueueStatus(QS_ALLINPUT) Then
      Label1.Caption = GetQueueStatus(QS_ALLINPUT)
      sijainti = GetCursorPos(koordinaatti)
      If Label1.Caption = 262144 Then
        Dim ctl As Control
        For Each ctl In Me.Controls
          'BorderStyle 2 - Sizable
          'formin reunuksen leveys = 50
          'formin otsikkopalkin korkeus = 475
          '2540 / 1440 = n. 1.76
          If CLng(koordinaatti.x / 1.76) >= _
          CLng((Me.Left + 50 + ctl.Left) / 1.76 / _
          Screen.TwipsPerPixelX) And _
          CLng(koordinaatti.x / 1.76) <= _
          CLng((Me.Left + 50 + ctl.Left + ctl.Width) / _
          1.76 / Screen.TwipsPerPixelX) And _
          CLng(koordinaatti.y / 1.76) >= _
          CLng((Me.Top + 475 + ctl.Top) / 1.76 / _
          Screen.TwipsPerPixelY) And _
          CLng(koordinaatti.y / 1.76) <= _
          CLng((Me.Top + 475 + ctl.Top + ctl.Height) / _
          1.76 / Screen.TwipsPerPixelY) Then
            Label2.Caption = ctl.Name
          End If
        Next
      End If
    End If
  Loop

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  End
End Sub

neau33 [03.03.2008 04:15:26]

EDIT:

BorderStyle 2

formin reunuksen leveys = 4px
reunuksen leveys = 4 * Screen.TwipsPerPixelX
jos Screen.TwipsPerPixelX = 15 on leveys 4 * 15 = 60 Twips

formin otsikkopalkin korkeus = 32px
palkin korkeus = 32 * Screen.TwipsPerPixelY
jos Screen.TwipsPerPixelY = 15 on korkeus 32 * 15 = 480 Twips

neau33 [03.03.2008 12:07:48]

Heippa taas!

VBA-ohjelmoijille erikseen...

'luokkamoduuliin...
'(Class1)
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Public Property Get TwipsPerPixelX() As Integer

  Dim nDC As Long: nDC = GetDC(0)
  TwipsPerPixelX = 1440 / GetDeviceCaps(nDC, LOGPIXELSX)
  ReleaseDC 0, nDC

End Property

Public Property Get TwipsPerPixelY() As Integer

  Dim nDC As Long: nDC = GetDC(0)
  TwipsPerPixelY = 1440 / GetDeviceCaps(nDC, LOGPIXELSY)
  ReleaseDC 0, nDC

End Property

'formin General-osioon...
Private c1 As New Class1, _
TwipsPerPixelX As Integer, _
TwipsPerPixelY As Integer

'käyttö...
Private Sub UserForm_Activate()
  TwipsPerPixelX = c1.TwipsPerPixelX
  TwipsPerPixelY = c1.TwipsPerPixelY
End Sub

neau33 [04.03.2008 17:57:57]

Heippa taas!

Kun nyt kerran lipsahti VBA-puolelle niin...mitäs jos rakennettaisiin VB6:lla aivan ikioma Screen-objekti VBE:a varten...Elikä tehdään VB6:lla ActiveX DLL...
Ekakas annetaan Project:lle nimeksi VBAScreen ja nimetään luokkamoduuli nimellä Screen ...
luokkamuduuliin:

Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetSystemMetrics32 Lib "user32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Public Property Get TwipsPerPixelX() As Integer

  Dim nDC As Long: nDC = GetDC(0)
  TwipsPerPixelX = 1440 / GetDeviceCaps(nDC, LOGPIXELSX)
  ReleaseDC 0, nDC

End Property

Public Property Get TwipsPerPixelY() As Integer

  Dim nDC As Long: nDC = GetDC(0)
  TwipsPerPixelY = 1440 / GetDeviceCaps(nDC, LOGPIXELSY)
  ReleaseDC 0, nDC

End Property

Public Property Get Width() As String

  Width = GetSystemMetrics32(SM_CXSCREEN)

End Property

Public Property Get Height() As String

  Height = GetSystemMetrics32(SM_CYSCREEN)

End Property

...valitaan File valikosta Make_VBAScreen.dll, tallennetaan Windows\System32 -hakemistoon ja suljetaan VB6. Klikataan: Käynnistä - Suorita - kirjoitetaan laatikkoon: regsvr32 C:\windows\system32\VBAScreen.dll ja klikataan OK

Avataan Excel - VBE - valitaan Tools-valikosta References, ruksataan laatikosta VBAScreen, klikataan OK ja lisätään projektiin lomake (UserForm)

'lomakkeen General-osioon:
Public Screen As Object

Private Sub UserForm_Activate()
  Set Screen = New VBAScreen.Screen
End Sub

'käyttö esim.
Private Sub UserForm_Click()
  MsgBox "Näyttöresoluutio: " & Screen.Width _
  & " x " & Screen.Height & vbCrlf _
  & "TwipsPerPixelX = " & Screen.TwipsPerPixelX _
  & "  TwipsPerPixelY = " & Screen.TwipsPerPixelX
End Sub

Private Sub UserForm_QueryClose( _
Cancel As Integer, CloseMode As Integer)
  Set Screen = Nothing
End Sub

ThisWorkbook:

Private Sub Workbook_SheetBeforeDoubleClick( _
ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Not UserForm1.Visible Then
    UserForm1.Show: SendKeys "{ESC}"
  End If
End Sub

Kray [04.03.2008 18:45:11]

Hei, teepä tuosta koodivinkki! En minä tarvitse, mutta joillekin saattaisi olla hyödyllinen!

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät

Kilpailu

Keskustelu: Ohjelmointikysymykset: VBA: Moniajo-oppaasta

JoreSoft [16.02.2008 12:35:48]

neau33 [02.03.2008 18:40:10]

neau33 [03.03.2008 02:49:10]

neau33 [03.03.2008 04:15:26]

neau33 [03.03.2008 12:07:48]

neau33 [04.03.2008 17:57:57]

Kray [04.03.2008 18:45:11]

Vastaus