Jag knappar på ett program som läser av en gamepad med ActiveX. Det enda jag behöver (just nu iallafall) är att VB6 ska reagera när jag trycker på knapparna.
Det funkar som jag vill nu (en label räknat upp +1 vid varje tryck), förutom att den enkla grejen tar 99% av datorns processorkraft, hela tiden. Efter att cmdStep2_Click() klickas börjar det... (den + cmdstep1... aktiverar gamepaden)

Det gör det oanvändbart.

Jag har utgått från ett exempel (som även i original kräver lika mycket) så jag får väl erkänna att jag inte har full koll på vad som händer.

Bifogar koden här nedan om någon har några bra tips. Jag är minst lika tacksam för en alternativ lösning :)

Den är lite lång, men vet man vad som kan vara problemet så hoppas jag man bara behöver skumma igenom det mesta.

Option Explicit
'The DirectXEvent tells us when stuff's happened
Implements DirectXEvent

'The root DirectX object; everything comes
'from here
Dim dx As New DirectX7
'The root DirectInput driver
Dim di As DirectInput
'This device will represent the joystick hardware
Dim diDev As DirectInputDevice
'This lets us count the available devices
Dim diDevEnum As DirectInputEnumDevices
Dim EventHandle As Long
Dim joyCaps As DIDEVCAPS
'js holds information ont he status
'of the joystick - Coordinates; buttons etc...
Dim js As DIJOYSTATE
'This is for the DeadZone
Dim DiProp_Dead As DIPROPLONG
'This sets the numbers that we use for our coordinates.
Dim DiProp_Range As DIPROPRANGE
'Saturation is where a value is automatically maxed
'above a certain point.
'if the scale were 1-100, and the saturation was
'90; any value above 89 would automatically be made 100
Dim DiProp_Saturation As DIPROPLONG
'Internal variables that we can access to tell if an axis is present
Dim AxisPresent(1 To 8) As Boolean
Dim running As Boolean

' *************** Nedan mina egna grejor********************
Dim TenSec As Integer  'spara varje 10 sek för framräkning av medelvärde
Dim OneMinute As Integer 'spara varje minut
Dim OneHour As Integer 'spara varje timme


Sub InitDirectInput()
    
    Set di = dx.DirectInputCreate()
    'Because DirectInput Enumerations contain information on lots of different
    'devices we must specify what we're looking for - in this case we want a
    'Joystick. We also want to make sure it's attached to the system. Without
    'this flag, DI may detect a set of joystick drivers; and report that there is
    'a joystick - even when it's not actually present.
    Set diDevEnum = di.GetDIEnumDevices(DIDEVTYPE_JOYSTICK, DIEDFL_ATTACHEDONLY)
    'Warn the user that there is no joystick present.
    If diDevEnum.GetCount = 0 Then
      MsgBox "No joystick attached."
      'There is no point continuing if there is
      'no joystick
      Unload Me
    End If
    
    'This is the enumeration; we've got this far
    'so we know there is at least one. For the purpose of
    'this tutorial we'll only bother using the default (first) device
    Dim i As Integer
    For i = 1 To diDevEnum.GetCount
        'There may well only be 1
        Call lstJoySticks.AddItem(diDevEnum.GetItem(i).GetInstanceName)
    Next
    
    ' Get an event handle to associate with the device
    EventHandle = dx.CreateEvent(Me)
    Exit Sub
    
'Something went wrong - there are several error flags
'that can be used to detect what the error problem was...
Error_Out:
    MsgBox "Error initializing DirectInput."
    Unload Me
    
End Sub


Private Sub cmdStep1_Click()
    'This is used in a loop later...
    running = True
       
    Set di = dx.DirectInputCreate()
    'Because DirectInput Enumerations contain information on lots of different
    'devices we must specify what we're looking for - in this case we want a
    'Joystick. We also want to make sure it's attached to the system. Without
    'this flag, DI may detect a set of joystick drivers; and report that there is
    'a joystick - even when it's not actually present.
    Set diDevEnum = di.GetDIEnumDevices(DIDEVTYPE_JOYSTICK, DIEDFL_ATTACHEDONLY)
    'Warn the user that there is no joystick present.
    If diDevEnum.GetCount = 0 Then
      MsgBox "No joystick attached."
      'There is no point continuing if there is
      'no joystick
      Unload Me
    End If
    
    'This is the enumeration; we've got this far
    'so we know there is at least one. For the purpose of
    'this tutorial we'll only bother using the default (first) device
    Dim i As Integer
    i = 1
    For i = 1 To diDevEnum.GetCount
       ' There may well only be 1
      '  Call lstJoySticks.AddItem(diDevEnum.GetItem(i).GetInstanceName)
    Next
    
    ' Get an event handle to associate with the device
    EventHandle = dx.CreateEvent(Me)
    
    'Changing these buttons around allows the user
    'to progress to the next step.
    cmdStep2.Enabled = True
    cmdStep1.Enabled = False
    
    Exit Sub
    
'Something went wrong - there are several error flags
'that can be used to detect what the error problem was...
Error_Out:
    MsgBox "Error initializing DirectInput."
    Unload Me
End Sub

Private Sub cmdStep2_Click()

    
    On Local Error Resume Next
    
    'Create the joystick device
    Set diDev = Nothing
    'Get the 1st Joystick. You'll want to enumerate available
    'devices first...
    Set diDev = di.CreateDevice(diDevEnum.GetItem(1).GetGuidInstance)
    'Tell DirectInput we're interacting with a Joystick
    diDev.SetCommonDataFormat DIFORMAT_JOYSTICK
    'With the cooperativelevel set to NONEXCLUSIVE we're likely to lose the
    'joystick easier - setting this to Exclusive will make it more difficult
    'for windows or other applications to steal it from us.
    diDev.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
    
    ' Find out what device objects it has
    diDev.GetCapabilities joyCaps
    'Call IdentifyAxes(diDev)
    
    ' Ask for notification of events
    Call diDev.SetEventNotification(EventHandle)

    ' Set deadzone for X and Y axis to 10 percent of the range of travel
    With DiProp_Dead
        .lData = 1000
        .lObj = DIJOFS_X
        .lSize = Len(DiProp_Dead)
        .lHow = DIPH_BYOFFSET
        .lObj = DIJOFS_X
        diDev.SetProperty "DIPROP_DEADZONE", DiProp_Dead
        .lObj = DIJOFS_Y
        diDev.SetProperty "DIPROP_DEADZONE", DiProp_Dead
    End With
    
    ' Set saturation zones for X and Y axis to 5 percent of the range
    With DiProp_Saturation
        .lData = 9500
        .lHow = DIPH_BYOFFSET
        .lSize = Len(DiProp_Saturation)
        .lObj = DIJOFS_X
         diDev.SetProperty "DIPROP_SATURATION", DiProp_Saturation
        .lObj = DIJOFS_Y
         diDev.SetProperty "DIPROP_SATURATION", DiProp_Saturation
    End With
    
    SetProp
    
    
    'Get the joystick
    diDev.Acquire
    'Me.Caption = "Joystick Sample: Querying Properties"
    
    ' Get the list of current properties
    ' USB joysticks wont call this callback until you play with the joystick
    ' so we call the callback ourselves the first time
    DirectXEvent_DXCallback 0
    
    ' Poll the device so that events are sure to be signaled.
    ' Usually this would be done in Sub Main or in the game rendering loop.
    
    While running = True
        DoEvents
        diDev.Poll
    Wend
End Sub

Private Sub DirectXEvent_DXCallback(ByVal eventid As Long)

' This is called whenever there's a change in the joystick state.
' We check the new state and update the display.
     Dim i As Integer
    'i = 1
    'If we haven't initialised yet; go no further
    If diDev Is Nothing Then Exit Sub
        
    'Get the device info
    On Local Error Resume Next
    diDev.GetDeviceStateJoystick js
    'Js should now contain all the up-to-date information
    'on the joystick. Unless there was an error:
    
    'If we lost the joystick then we want to get it back again.
    If Err.Number = DIERR_NOTACQUIRED Or Err.Number = DIERR_INPUTLOST Then
        diDev.Acquire
        Exit Sub
    End If
      
        'A simple example of moving a dummy sprite
        'around based on input from the joystick
        Select Case js.x
            Case 0 'Full Left
                Shape1.Left = 0
            Case 5000 'Middle
                Shape1.Left = 1
            Case 10000 'Full Right
                Shape1.Left = 2
        End Select
        
        Select Case js.y
            Case 0 'Full up
                Shape1.Top = 0
            Case 5000 'Middle
                Shape1.Top = 1
            Case 10000 'Full down
                Shape1.Top = 2
        End Select
                    
                   
               'Use these properties to get the coordinates of other
               'axis; this example isn't interested in them though.
               'Remember to make sure that they exist before checking
               'them though.
               '    js.z

               '    js.rx

               '    js.ry

               '    js.rz

               '    js.slider(0)

               '    js.slider(1)
      
      
    'For the next set of information you'll need to create two
    'standard Listboxes; lstButtons and lstHats.
    
    'If you're interested in the buttons; uncomment this
    'code:
    For i = 0 To joyCaps.lButtons - 1
        Select Case js.buttons(i)
      Case 0 '
           ' lstButton.List(i) = "Button " + CStr(i + 1) + ": av"
            
  
           
            'Label1.Caption = "av"
            
    
        Case Else  'knapp sluten
           ' lstButton.List(i) = "Button " + CStr(i + 1) + ": Down"
            
            
            
     If js.buttons(0) Then
            Label1.Caption = Label1.Caption + 1
     End If
     
            
            
    
        End Select
        
        
        
        
    Next
        
    'This is how to get at the Hats on a joystick
    'But this example is not interested in them
    'For i = 0 To joyCaps.lPOVs - 1
    '    lstHat.List(i) = "POV " + CStr(i + 1) + ": " + CStr(js.POV(i))
    'Next

    Exit Sub
    
err_out:
    'Replace this in a normal application; the chances are that
    'this message box will say "Automation Error : -20880808" (or similiar)
    'the user is not going to know what this is....
    MsgBox Err.Description & " : " & Err.Number, vbApplicationModal
    End

End Sub

Private Sub Form_Unload(cancel As Integer)
        Me.Caption = "Unloading..."
        DoEvents
        If EventHandle <> 0 Then dx.DestroyEvent EventHandle
        running = False
        DoEvents
        End
End Sub

Sub SetProp()
    ' Set range for all axes
    With DiProp_Range
        .lHow = DIPH_DEVICE
        .lSize = Len(DiProp_Range)
        'When the joystick is centered it will
        'be half way between these two values,
        'in this case; 5000
        .lMin = 0
        .lMax = 10000
        'Should you want to have a calibrate facility
        'you could use this...
    End With
    'Apply the property to DirectInput
    diDev.SetProperty "DIPROP_RANGE", DiProp_Range
End Sub



Sub IdentifyAxes(diDev As DirectInputDevice)
'Call this procedure if you want to know more about the axis.....

    'For safe usage we not only want to know how
    'many axis are present; but which axis are present.
   
   Dim didoEnum As DirectInputEnumDeviceObjects
   Dim dido As DirectInputDeviceObjectInstance
   Dim i As Integer
   
   For i = 1 To 8
     'By default we'll assume no axis is present
     AxisPresent(i) = False
     'then we'll set the balue to true if we detect one:
   Next
   
   ' Enumerate the axes by telling DirectInput we only
   'want it to list the available axis
   Set didoEnum = diDev.GetDeviceObjectsEnum(DIDFT_AXIS)
   
   ' Check data offset of each axis to learn what it is
   
   For i = 1 To didoEnum.GetCount
     Set dido = didoEnum.GetItem(i)
         Select Case dido.GetOfs
            'These are the two normal ones
            Case DIJOFS_X
              AxisPresent(1) = True
            Case DIJOFS_Y
              AxisPresent(2) = True
            'These lot are the diagonals
            Case DIJOFS_Z
              AxisPresent(3) = True
            Case DIJOFS_RX
              AxisPresent(4) = True
            Case DIJOFS_RY
              AxisPresent(5) = True
            Case DIJOFS_RZ
              AxisPresent(6) = True
            Case DIJOFS_SLIDER0
              AxisPresent(7) = True
            Case DIJOFS_SLIDER1
              AxisPresent(8) = True
         End Select
 
   Next
End Sub

Du har en loop som kommer köras enda tills programmet stängs av ;)

Hmm, är det kanske:

' Poll the device so that events are sure to be signaled.
' Usually this would be done in Sub Main or in the game rendering loop.

While running = True
DoEvents
diDev.Poll
Wend

?

Sweeeet! det löste problemet, Tackar!
Och det verkar funka ändå :)