Форум программистов, компьютерный форум, киберфорум
Наши страницы
Basic
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.75/12: Рейтинг темы: голосов - 12, средняя оценка - 4.75
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
1

Мышка FreeBasic (Получение мгновенного шага)

29.12.2012, 02:34. Просмотров 2377. Ответов 23
Метки нет (Все метки)

Всех приветствую!
Вот хотел было сделать свою процедурку для обработки мыши, но не тут то было.
Проблема с получением приращения мыши.
Всё уже перепробовал.
Делаю так:
QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
     Mxo = Mxg: Myo = Myg      '  Сохраним старые координаты
   '   Определяем новые координаты мыши
     GetMouse Mxg, Myg, Whl, Btn, 0
   '   Ставим мышь в центр через интервалы времени
     Otsch = (Otsch + 1) AND 127
     IF Otsch = 0 THEN
         Mxo = ScreenXRez SHR 1: Myo = ScreenYRez SHR 1
         SetMouse Mxo, Myo
         Mxg = Mxo: Myg = Myo
     END IF
   '   Считаем дельту
     Mdx = Mxg - Mxo: Mdy = Myg - Myo  
   '   Добавляем к координатам приращение мыши
     Mx = Mx + Mdx: My = My + Mdy
     IF Mx < 0 THEN Mx = 0
     IF Mx > ScreenXRez - 1 THEN Mx = ScreenXRez -1
     IF My < 0 THEN My = 0
     IF My > ScreenYRez - 1 THEN My = ScreenYRez -1
Тут я понимаю, что встроенного функционала по мыши не хватает.
Может быть кто подскажет, как нормально получить дельту координат.

Вот такой вариант не канает, мышь плохо реагирует(знаю что должна реагировать, но увы):
GetMouse Mgx, Mgy
SetMouse ЦентрЭкранаX, ЦентрЭкранаY
Mdx = Mgx - ЦентрЭкранаX
Mdy = Mgy - ЦентрЭкранаY
Может как-то через WinAPI ?
Вообще нужно это сами понимаете зачем, хочу прописать свой массив отклонений
и менять сенсу в программе.
1
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
29.12.2012, 02:34
Ответы с готовыми решениями:

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

Нахождение мгновенного значения токов
Помогите решить задачку Правила форума: 5.18. Запрещено размещать задания в виде картинок и...

Программа для мгновенного обмена сообщениями
Скажи, пожалуйста, если писать программу для обмена через Интернет, а не по локальной сети. То что...

Записать выражение мгновенного значения указанной электрической величины
Здравствуйте всем. Задали задачки две, в электричестве я вообще полный 0, искренне прошу...

FreeBASIC
Заметил, что уже имеющиеся на форуме темы в разделах: - QBasic - Visual Basic - VBA - Pure...

23
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
29.12.2012, 06:31 2
Такой пример пойдет?:

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
'Подключаем файл с объявлениями
#INCLUDE "fbgfx.bi"
'открываем пространство имен FB
USING fb
'Объявляем структуру
DIM e AS EVENT
'Запускаем экран
Screenres 640, 480
DO
 
    IF (Screenevent(@e)) THEN 'если произошло событие
        SELECT CASE e.TYPE    'тогда узнаем какое
            CASE EVENT_KEY_PRESS
                IF (e.scancode = SC_ESCAPE) THEN 'если ESC тогда выход из программы
                    END
                END IF
                PRINT "scancode pressed key: " & e.scancode ' клавиша нажата
            CASE EVENT_KEY_RELEASE
                PRINT "scancode released key:  " & e.scancode ' клавиша отжата
            CASE EVENT_MOUSE_MOVE ' перемещение мыши
                PRINT "mouse moved to " _
                & e.x & "," & e.y & " (delta " & e.dx & "," & e.dy & ")"
            CASE EVENT_WINDOW_CLOSE ' закрытие окна
                END
        END SELECT
    END IF
LOOP
1
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
29.12.2012, 10:07  [ТС] 3
Такой пример пойдет?
К сожалению не подходит, потому что, при выходе за окно уже дельта не возвращается.
А если ставлю SetMouse , , , 1 чтобы мышь всегда была в окне, то получается, что
когда мышь доходит до границы - упирается и дельта тоже не возвращается.
Я конечно ещё поэкспериментирую с этим кодом(т.к. он ловит событие), но боюсь, что не
получится. Вообще никогда не думал что возникнут сложности с мышкой, вроде бы система
должна иметь возможность возвращать дельту непосредственно.
0
SoftIce
es geht mir gut
11005 / 4404 / 1116
Регистрация: 27.07.2011
Сообщений: 10,785
Завершенные тесты: 1
29.12.2012, 10:51 4
Извините, что вмешиваюсь, но на всякий случай спрошу.

Это, конечно, опечатка? :

Цитата Сообщение от >Quiet Snow< Посмотреть сообщение
GetMouse Mgx
Цитата Сообщение от >Quiet Snow< Посмотреть сообщение
GetMouse Mxg
0
29.12.2012, 10:51
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
29.12.2012, 12:05  [ТС] 5
Это, конечно, опечатка?
SoftIce, нет, просто мне надо было одинаковые переменные в 2-х кусках
кода привести, а я писал от балды, код ниже был просто иллюстрацией.
1
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
29.12.2012, 12:05 6
Для винды:

PureBasic
1
2
3
4
5
6
7
8
9
10
11
12
13
#Include "windows.bi"
Dim As Point pt,oldpt,deltapt
 
Do
    GetCursorPos(@pt)
    deltapt.x = pt.x - oldpt.x
    deltapt.y = pt.y - oldpt.y
   oldpt.x = pt.x
   oldpt.y = pt.y
   cls  
    ? "x=";deltapt.x,"y=";deltapt.y
    Sleep(10)   
Loop Until MultiKey(1)
1
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
29.12.2012, 13:01  [ТС] 7
Сейчас буду пробовать, но уже вижу, что дельта работает, пока мышь не уткнулась в край экрана.
В лучшем случае если размещать курсор по центру, такой дельты хватит на 2 кадра максимального
приращения, зависит ещё от разрешения моника и сенсы установленной в винде(а то и вообще может
не хватить).
Суть в том, что если к примеру я функцией SetMouse ставлю позицию курсора, то как бы
сбрасывается весь текущий прогресс по накоплению дельты с момента последнего изменения
этого дельта во внутреннем состоянии того интерфейса, которым пользуется FB.
Это даёт очень неприятный эффект, когда вдруг мышь на дюлю секунды перестаёт реагировать
и в результате указатель не смещается, как должен, проверяется это круговыми движениями
мыши. Такие ошибки возникают десятки раз в секунду и из-за этого теряется точность
позиционирования.
Пока попробую с GetCursorPos и SetCursorPos разобраться, если получится нормально - напишу.
У меня точная мышка, потому все эти косяки чувствуются сразу.

А нет на FB примеров с DirectInput ? На си вот много вижу, а под FB что-то не гуглится.
0
locm
29.12.2012, 13:04
  #8

Не по теме:

Цитата Сообщение от >Quiet Snow< Посмотреть сообщение
На си вот много вижу, а под FB что-то не гуглится.
А если Си-примеры переписать под FB?

0
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
29.12.2012, 13:36  [ТС] 9
locm, ответ очевиден, иначе не спрашивал бы.

А пока вот такая заготовка. Работает вроде, но всё равно точность паршивит.
На рабочем столе мышь себя лучше ведёт.
В принципе пока и так сойдёт, со временем может найдётся вариант получше.
PureBasic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
   #INCLUDE ONCE "fbgfx.bi"
   #INCLUDE ONCE "windows.bi"
'  $Lang: "FBLite"
 
DECLARE SUB  Init ()
 
DECLARE SUB  LoadCur ()
DECLARE SUB  ALLInput ()
 
 
    '   Технич. переменные
 
DIM SHARED AS INTEGER Mx, My
DIM SHARED AS POINT Md, Cntr
DIM SHARED Mdx AS INTEGER, Mdy AS INTEGER
 
 
DIM SHARED CurImg(991) AS UBYTE
DIM SHARED AS UINTEGER ScreenXRez, ScreenYRez
 
ScreenXRez = 640: ScreenYRez = 480
'SCREENINFO ScreenXRez, ScreenYRez
 
 
     Init
 
COLOR  , RGB(20, 20, 20)
     DO: CLS
         ALLInput
 
             PUT (Mx, My), CurImg, ALPHA
 
         FLIP
         SLEEP 10, 1
     LOOP
 
 
CurDatL:
DATA 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 2, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 2, 2, 2, 2, 1, 0, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 2, 2, 2, 2, 2, 1, 0, 0, 0, 0, 0
DATA 1, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0
DATA 1, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
DATA 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
 
SUB  Init ()
 
SCREENRES ScreenXRez, ScreenYRez, 32, 2, 0
SCREENSET 1, 0
 
       '   Загрузим курсор
     LoadCur
 
 
Mx = ScreenXRez SHR 1
My = ScreenYRez SHR 1
SetMouse Mx, My, 0, 1
GetCursorPos(@Cntr)
 
END SUB
 
SUB  LoadCur ()
DIM  ix AS INTEGER, iy AS INTEGER, Cv AS UINTEGER
RESTORE CurDatL
    FOR iy = 0 TO 14
          FOR ix = 0 TO 14
          READ Cv
          SELECT CASE Cv
             CASE 1: Cv = RGBA(0, 0, 0, 255)
             CASE 2: Cv = RGBA(255, 255, 255, 255)
             CASE ELSE: Cv = RGBA(0, 0, 0, 0)
          END SELECT
                PSET (ix, iy), Cv
    NEXT ix, iy
    GET (0, 0)-(14, 14), CurImg(0)
END SUB
 
SUB ALLInput ()
   '___   Клавиатура
     Kb$ = INKEY$
 
   '___   Мышь
   '   Определяем новые координаты мыши
     GetCursorPos(@Md)
 
   '   Ставим мышь в центр
     SetCursorPos(Cntr.x, Cntr.y)
 
   '   Считаем дельту
     Mdx = Md.x - Cntr.x
     Mdy = Md.y - Cntr.y
  
   '   Добавляем к координатам приращение мыши
     Mx = Mx + Mdx: My = My + Mdy
 
   '   Границы мыши
     IF Mx < 0 THEN Mx = 0
     IF Mx > ScreenXRez - 1 THEN Mx = ScreenXRez -1
     IF My < 0 THEN My = 0
     IF My > ScreenYRez - 1 THEN My = ScreenYRez -1
 
     IF Kb$ = CHR(27) THEN END
END SUB
1
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
29.12.2012, 14:14 10
Цитата Сообщение от >Quiet Snow< Посмотреть сообщение
А нет на FB примеров с DirectInput ? На си вот много вижу, а под FB что-то не гуглится.
Сказать по чести, я примеров с DirectX , DirectInput , DirectDraw и пр. почти не встречал на FB. Сообщество FB больше смотрит в сторону OpenGl. А пример на СИ большой? Просто хотелось бы взглянуть, вдруг настанет время и самому понадобится...
1
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
29.12.2012, 14:21  [ТС] 11
А пример на СИ большой?
Вот этот я смотрел:
http://savardge.narod.ru/dx/article_dx10.html

Думаю для человека, который знает и си и FB - это фигня, 10 минут переписать под FB.
А я и FB то толком не знаю))) ласось же .
1
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
29.12.2012, 15:11 12
Не с COM я заморачиваюсь редко, исключительно если понимаю смысл работы того, что переписываю. А с директами я ни разу не дружил .
1
Quiet Snow
4416 / 1313 / 378
Регистрация: 25.04.2010
Сообщений: 3,421
30.12.2012, 01:53  [ТС] 13
Сообщество FB больше смотрит в сторону OpenGl.
Я теперь тоже смотрю именно в эту сторону. Ваш перевод статьи великолепен,
а исходник поясняет про режимы смешивания. Для 2D однозначно OpenGL.

stabud, есть небольшой вопрос по клавиатуре, не буду создавать
отдельную тему. Вопрос: на русских системах по умолчанию стоит русский язык
и INKEY$ при вводе с клавиатуры выдаёт странные значения, т.е. он вообще ничего
не выдаёт(при вводе любой русской буквы возвращается ASCII код 63).
К тому же для переключения раскладки нужно нажать соотв. комбинацию и
перетащить окно, если не перетаскивать - раскладка не переключается.
Короче говоря как сделать, чтобы всегда при старте была английская раскладка,
потому как если это будет, свой костыль я напишу для русских символов))).
Это касается графического режима fbgfx(когда в окошке, без окна и перетаскивать
то нечего).
0
Pro_grammer
Модератор
6222 / 2309 / 450
Регистрация: 24.04.2011
Сообщений: 4,125
Записей в блоге: 10
30.12.2012, 08:09 14
Цитата Сообщение от >Quiet Snow< Посмотреть сообщение
Короче говоря как сделать, чтобы всегда при старте была английская раскладка,
Что то типа этого при запуске
PureBasic
1
2
3
If GetKeyboardLayout(0) = 68748313 Then ' если  Rus то на US 
            ActivateKeyboardLayout(1, 0)
        EndIf
Правда, не знаю, как на FB эти API декларируются.
1
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
30.12.2012, 11:27 15
Цитата Сообщение от Pro_grammer Посмотреть сообщение
Что то типа этого при запуске
PureBasic
1
2
3
If GetKeyboardLayout(0) = 68748313 Then ' если  Rus то на US 
            ActivateKeyboardLayout(1, 0)
        EndIf
Правда, не знаю, как на FB эти API декларируются.
Эти API работают для своих созданных окон, но для окон , созданных с помощью Screen и ScreenRes почему-то не катит. Я уже задавал вопрос на оф. сайте про ввод русских символов в графическое окно. Прозвучал ответ: "ждите в будующих версиях". Так что пока для графики, надо какой-то костыль изобретать. Или создавать свое окно вместо Screen и Screenres. Пример ниже я адаптировал из цикла уроков от NEHE:

PureBasic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
'/*
' *  This Code Was Created By Jeff Molofee 2000
' *  A HUGE Thanks To Fredric Echols For Cleaning Up
' *  And Optimizing This Code, Making It More Flexible!
' *  If You've Found This Code Useful, Please Let Me Know.
' *  Visit My Site At nehe.gamedev.net
' */
 
#Include "windows.bi"  '' Header File For Windows
#Include "crt/string.bi"
#Include Once "GL/gl.bi"
#Include Once "GL/glu.bi"
 
Dim Shared As HDC hDC  ' Private GDI Device Context
Dim Shared As HGLRC  hRC  ' Permanent Rendering Context
Dim Shared As HWND  hWnd  ' Holds Our Window Handle
Dim Shared As HINSTANCE    hInstance    ' Holds The Instance Of The Application
 
Dim Shared As bool    keys(256)   ' Array Used For The Keyboard Routine
Dim Shared As bool    active = TRUE  ' Window Active Flag Set To TRUE By Default
Dim Shared As bool    fullscreen = TRUE    ' Fullscreen Flag Set To Fullscreen Mode By Default
Dim Shared As ZString*32 classOGL = "OpenGL"
Declare Function WndProc(As HWND, As UINT,As WPARAM, As LPARAM) As Integer    ' Declaration For WndProc
Declare Function WinMain(    hInstance As HINSTANCE    , _   ' Instance
hPrevInstance As HINSTANCE    , _  ' Previous Instance
lpCmdLine As LPSTR , _   ' Command Line Parameters
nCmdShow As Integer)As Integer   ' Window Show State
 
WinMain( GetModuleHandle(NULL) ,NULL,GetCommandLine(), SW_SHOWNORMAL )
 
Sub ReSizeGLScene(width_ As GLsizei ,height As  GLsizei )  ' Resize And Initialize The GL Window
 
    If (height=0)    Then    height=1        ' Prevent A Divide By Zero By  Making Height Equal One
 
    glViewport(0,0,width_,height)      ' Reset The Current Viewport
 
    glMatrixMode(GL_PROJECTION)      ' Select The Projection Matrix
    glLoadIdentity()       ' Reset The Projection Matrix
 
    ' Calculate The Aspect Ratio Of The Window
    gluPerspective(45.0f,Cast(GLfloat,Width_)/Cast(GLfloat,height),0.1f,100.0f)
 
    glMatrixMode(GL_MODELVIEW)       ' Select The Modelview Matrix
    glLoadIdentity()         ' Reset The Modelview Matrix
End Sub
 
Function InitGL() As Integer                              ' All Setup For OpenGL Goes Here
    glShadeModel(GL_SMOOTH)       ' Enable Smooth Shading
    glClearColor(0.0f, 0.0f, 0.0f, 0.5f)    ' Black Background
    glClearDepth(1.0f)         ' Depth Buffer Setup
    glEnable(GL_DEPTH_TEST)       ' Enables Depth Testing
    glDepthFunc(GL_LEQUAL)       ' The Type Of Depth Testing To Do
    glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)    ' Really Nice Perspective Calculations
    Return TRUE                              ' Initialization Went OK
End Function
 
Function DrawGLScene()As Integer         ' Here's Where We Do All The Drawing
    glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)    ' Clear Screen And Depth Buffer
    glLoadIdentity()        ' Reset The Current Modelview Matrix
    glTranslatef(-1.5f,0.0f,-6.0f)      ' Move Left 1.5 Units And Into The Screen 6.0
    glBegin(GL_TRIANGLES)        ' Drawing Using Triangles
    glVertex3f( 0.0f, 1.0f, 0.0f)     ' Top
    glVertex3f(-1.0f,-1.0f, 0.0f)     ' Bottom Left
    glVertex3f( 1.0f,-1.0f, 0.0f)     ' Bottom Right
    glEnd()                              ' Finished Drawing The Triangle
    glTranslatef(3.0f,0.0f,0.0f)      ' Move Right 3 Units
    glBegin(GL_QUADS)         ' Draw A Quad
    glVertex3f(-1.0f, 1.0f, 0.0f)     ' Top Left
    glVertex3f( 1.0f, 1.0f, 0.0f)     ' Top Right
    glVertex3f( 1.0f,-1.0f, 0.0f)     ' Bottom Right
    glVertex3f(-1.0f,-1.0f, 0.0f)     ' Bottom Left
    glEnd()                              ' Done Drawing The Quad
    Return TRUE                              ' Everything Went OK
End Function
 
Sub KillGLWindow()        ' Properly Kill The Window
    If (fullscreen) Then                              ' Are We In Fullscreen Mode?
        ChangeDisplaySettings(NULL,0)     ' If So Switch Back To The Desktop
        ShowCursor(TRUE)        ' Show Mouse Pointer
    EndIf
 
    If (hRC)    Then                              ' Do We Have A Rendering Context?
        If (wglMakeCurrent(NULL,NULL) = FALSE)Then     ' Are We Able To Release The DC And RC Contexts?
            MessageBox(NULL,"Release Of DC And RC Failed.","SHUTDOWN ERROR",MB_OK Or MB_ICONINFORMATION)
        EndIf
 
        If (wglDeleteContext(hRC) = FALSE) Then     ' Are We Able To Delete The RC?
            MessageBox(NULL,"Release Rendering Context Failed.","SHUTDOWN ERROR",MB_OK Or MB_ICONINFORMATION)
        EndIf
        hRC=NULL                              ' Set RC To NULL
    EndIf
 
    If (hDC=TRUE And (ReleaseDC(hWnd,hDC) = FALSE))    Then    ' Are We Able To Release The DC
        MessageBox(NULL,"Release Device Context Failed.","SHUTDOWN ERROR",MB_OK Or MB_ICONINFORMATION)
        hDC=NULL                              ' Set DC To NULL
    EndIf
 
    If (hWnd=TRUE And (DestroyWindow(hWnd) = FALSE))    Then    ' Are We Able To Destroy The Window?
        MessageBox(NULL,"Could Not Release hWnd.","SHUTDOWN ERROR",MB_OK Or MB_ICONINFORMATION)
        hWnd=NULL                              ' Set hWnd To NULL
    EndIf
 
    If (UnregisterClass("OpenGL",hInstance) = FALSE)    Then  ' Are We Able To Unregister Class
        MessageBox(NULL,"Could Not Unregister Class.","SHUTDOWN ERROR",MB_OK Or MB_ICONINFORMATION)
        hInstance=NULL         ' Set hInstance To NULL
    EndIf
End Sub
 
'/*    This Code Creates Our OpenGL Window.  Parameters Are:     *
' *    title   - Title To Appear At The Top Of The Window    *
' *    width   - Width Of The GL Window Or Fullscreen Mode    *
' *    height   - Height Of The GL Window Or Fullscreen Mode   *
' *    bits   - Number Of Bits To Use For Color (8/16/24/32)   *
' *    fullscreenflag    - Use Fullscreen Mode (TRUE) Or Windowed Mode (FALSE)    */
 
Function CreateGLWindow(title As ZString Ptr , Width_ As Integer ,height As Integer ,bits As Integer ,fullscreenflag As bool ) As BOOL
    Dim As GLuint PixelFormat   ' Holds The Results After Searching For A Match
    Dim As WNDCLASS    wc      ' Windows Class Structure
    Dim As DWORD  dwExStyle    ' Window Extended Style
    Dim As DWORD  dwStyle    ' Window Style
    Dim As RECT  WindowRect    ' Grabs Rectangle Upper Left / Lower Right Values
    WindowRect.left = 0   ' Set Left Value To 0
    WindowRect.right = Width_  ' Set Right Value To Requested Width
    WindowRect.top = 0   ' Set Top Value To 0
    WindowRect.bottom = height  ' Set Bottom Value To Requested Height
 
    fullscreen=fullscreenflag   ' Set The Global Fullscreen Flag
 
    hInstance   = GetModuleHandle(NULL)    ' Grab An Instance For Our Window
    wc.style   = CS_HREDRAW Or CS_VREDRAW Or CS_OWNDC    ' Redraw On Size, And Own DC For Window.
    wc.lpfnWndProc  = Cast(WndProc, @WndProc)     ' WndProc Handles Messages
    wc.hInstance  = hInstance       ' Set The Instance
    wc.hIcon   = LoadIcon(NULL, IDI_WINLOGO)   ' Load The Default Icon
    wc.hCursor   = LoadCursor(NULL, IDC_ARROW)   ' Load The Arrow Pointer
    wc.hbrBackground    = NULL         ' No Background Required For GL
    wc.lpszMenuName  = NULL         ' We Don't Want A Menu
    wc.lpszClassName    = StrPtr(classOGL)       ' Set The Class Name
 
    If (RegisterClass(@wc)=FALSE) Then    ' Attempt To Register The Window Class
        MessageBox(NULL,"Failed To Register The Window Class.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE                              ' Return FALSE
    EndIf
 
    If (fullscreen) Then                              ' Attempt Fullscreen Mode?
        Dim As DEVMODE dmScreenSettings        ' Device Mode
        memset(@dmScreenSettings,0,SizeOf(dmScreenSettings))    ' Makes Sure Memory's Cleared
        dmScreenSettings.dmSize=SizeOf(dmScreenSettings)  ' Size Of The Devmode Structure
        dmScreenSettings.dmPelsWidth    = width_    ' Selected Screen Width
        dmScreenSettings.dmPelsHeight    = height    ' Selected Screen Height
        dmScreenSettings.dmBitsPerPel    = bits     ' Selected Bits Per Pixel
        dmScreenSettings.dmFields=DM_BITSPERPEL+DM_PELSWIDTH+DM_PELSHEIGHT
 
        ' Try To Set Selected Mode And Get Results.  NOTE: CDS_FULLSCREEN Gets Rid Of Start Bar.
        If (ChangeDisplaySettings(@dmScreenSettings,CDS_FULLSCREEN)<>DISP_CHANGE_SUCCESSFUL) Then
            ' If The Mode Fails, Offer Two Options.  Quit Or Use Windowed Mode.
            If (MessageBox(NULL,!"The Requested Fullscreen Mode Is Not Supported By\nYour Video Card. Use Windowed Mode Instead?","NeHe GL",MB_YESNO+MB_ICONEXCLAMATION)=IDYES) Then
                fullscreen=FALSE  ' Windowed Mode Selected.  Fullscreen = FALSE
            Else
                ' Pop Up A Message Box Letting User Know The Program Is Closing.
                MessageBox(NULL,"Program Will Now Close.","ERROR",MB_OK+MB_ICONSTOP)
                Return FALSE         ' Return FALSE
            EndIf
        EndIf
    EndIf
 
    If (fullscreen) Then                              ' Are We Still In Fullscreen Mode?
        dwExStyle=WS_EX_APPWINDOW        ' Window Extended Style
        dwStyle=WS_POPUP                              ' Windows Style
        ShowCursor(FALSE)                              ' Hide Mouse Pointer
    Else
        dwExStyle=WS_EX_APPWINDOW + WS_EX_WINDOWEDGE   ' Window Extended Style
        dwStyle=WS_OVERLAPPEDWINDOW       ' Windows Style
    EndIf
 
    AdjustWindowRectEx(@WindowRect, dwStyle, FALSE, dwExStyle)  ' Adjust Window To True Requested Size
 
    ' Create The Window
    hWnd=CreateWindowEx(    dwExStyle, _       ' Extended Style For The Window
    "OpenGL", _       ' Class Name
    title, _        ' Window Title
    dwStyle + _       ' Defined Window Style
    WS_CLIPSIBLINGS + _     ' Required Window Style
    WS_CLIPCHILDREN, _     ' Required Window Style
    0, 0,    _       ' Window Position
    WindowRect.right-WindowRect.left, _    ' Calculate Window Width
    WindowRect.bottom-WindowRect.top, _    ' Calculate Window Height
    NULL,    _       ' No Parent Window
    NULL,    _       ' No Menu
    hInstance, _       ' Instance
    NULL)
    If hwnd = FALSE Then       ' Dont Pass Anything To WM_CREATE
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Window Creation Error.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    Static As PIXELFORMATDESCRIPTOR pfd   ' pfd Tells Windows How We Want Things To Be
    With pfd
        .nSize        = SizeOf(PIXELFORMATDESCRIPTOR)' Size Of This Pixel Format Descriptor
        .nVersion     = 1  ' Version Number
        .dwFlags      = PFD_DRAW_TO_WINDOW _  ' Format Must Support Window
        Or PFD_SUPPORT_OPENGL _ ' Format Must Support OpenGL
        Or PFD_DOUBLEBUFFER  ' Must Support Double Buffering
        .iPixelType   = PFD_TYPE_RGBA  ' Request An RGBA Format
        .iLayerType   = PFD_MAIN_PLANE ' Main Drawing Layer
        .cColorBits   = bits ' Select Our Color Depth
        .cDepthBits   = 16 ' 16Bit Z-Buffer (Depth Buffer)
    End With
 
    hDC=GetDC(hWnd)
    If (hDC=FALSE)    Then      ' Did We Get A Device Context?
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Can't Create A GL Device Context.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    PixelFormat=ChoosePixelFormat(hDC,@pfd)
    If (PixelFormat=FALSE)    Then' Did Windows Find A Matching Pixel Format?
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Can't Find A Suitable PixelFormat.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    If(SetPixelFormat(hDC,PixelFormat,@pfd) = FALSE)    Then    ' Are We Able To Set The Pixel Format?
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Can't Set The PixelFormat.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    hRC=wglCreateContext(hDC)
    If (hRC = FALSE) Then    ' Are We Able To Get A Rendering Context?
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Can't Create A GL Rendering Context.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    If(wglMakeCurrent(hDC,hRC) = FALSE) Then     ' Try To Activate The Rendering Context
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Can't Activate The GL Rendering Context.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    ShowWindow(hWnd,SW_SHOW)      ' Show The Window
    SetForegroundWindow(hWnd)      ' Slightly Higher Priority
    SetFocus(hWnd)         ' Sets Keyboard Focus To The Window
    ReSizeGLScene(width_, height)     ' Set Up Our Perspective GL Screen
 
    If (InitGL() = FALSE)    Then        ' Initialize Our Newly Created GL Window
        KillGLWindow()        ' Reset The Display
        MessageBox(NULL,"Initialization Failed.","ERROR",MB_OK+MB_ICONEXCLAMATION)
        Return FALSE        ' Return FALSE
    EndIf
 
    Return TRUE         ' Success
End Function
 
Function WndProc(hWnd As HWND    ,    _  ' Handle For This Window
    uMsg As UINT, _   ' Message For This Window
    wParam As WPARAM, _   ' Additional Message Information
    lParam As LPARAM) As Integer   ' Additional Message Information
 
    Select Case uMsg        ' Check For Windows Messages
        Case WM_ACTIVATE       ' Watch For Window Activate Message
            If (HiWord(wParam) = FALSE)    Then    ' Check Minimization State
                active=TRUE      ' Program Is Active
            Else
                active=FALSE      ' Program Is No Longer Active
            EndIf
            Return 0        ' Return To The Message Loop
        Case WM_SYSCOMMAND       ' Intercept System Commands
            Select Case wParam       ' Check System Calls
                Case SC_SCREENSAVE     ' Screensaver Trying To Start?
                Case SC_MONITORPOWER    ' Monitor Trying To Enter Powersave?
                    Return 0       ' Prevent From Happening
            End Select
        Case WM_CLOSE        ' Did We Receive A Close Message?
            PostQuitMessage(0)      ' Send A Quit Message
            Return 0        ' Jump Back
        Case WM_KEYDOWN       ' Is A Key Being Held Down?
            keys(wParam) = TRUE     ' If So, Mark It As TRUE
            ActivateKeyboardLayout(HKL_NEXT ,KLF_REORDER)
            Return 0        ' Jump Back
        Case WM_KEYUP        ' Has A Key Been Released?
            keys(wParam) = FALSE     ' If So, Mark It As FALSE
            Return 0       ' Jump Back
        Case WM_SIZE        ' Resize The OpenGL Window
            ReSizeGLScene(LoWord(lParam),HiWord(lParam))  ' LoWord=Width, HiWord=Height
            Return 0        ' Jump Back
    End Select
    ' Pass All Unhandled Messages To DefWindowProc
    Return DefWindowProc(hWnd,uMsg,wParam,lParam)
End Function
 
Function WinMain(    hInstance As HINSTANCE    , _   ' Instance
    hPrevInstance As HINSTANCE    , _  ' Previous Instance
    lpCmdLine As LPSTR , _   ' Command Line Parameters
    nCmdShow As Integer)As Integer   ' Window Show State
 
    Dim As MSG  msg         ' Windows Message Structure
    Dim As BOOL    done = FALSE       ' Bool Variable To Exit Loop
 
    ' Ask The User Which Screen Mode They Prefer
    If (MessageBox(NULL,"Would You Like To Run In Fullscreen Mode?", "Start FullScreen?",MB_YESNO+MB_ICONQUESTION)=IDNO) Then
        fullscreen = FALSE       ' Windowed Mode
    EndIf
 
    ' Create Our OpenGL Window
    If (CreateGLWindow("NeHe's OpenGL Framework",640,480,16,fullscreen) = FALSE) Then
        Return 0         ' Quit If Window Was Not Created
    EndIf
 
    While(done = FALSE)         ' Loop That Runs While done=FALSE
        If (PeekMessage(@msg,NULL,0,0,PM_REMOVE))Then    ' Is There A Message Waiting?
            If (msg.message=WM_QUIT)    Then   ' Have We Received A Quit Message?
                done=TRUE       ' If So done=TRUE
            Else         ' If Not, Deal With Window Messages
                TranslateMessage(@msg)    ' Translate The Message
                DispatchMessage(@msg)    ' Dispatch The Message
            EndIf
        Else                              ' If There Are No Messages
            ' Draw The Scene.  Watch For ESC Key And Quit Messages From DrawGLScene()
            If (active) Then        ' Program Active?
                If (keys(VK_ESCAPE))    Then   ' Was ESC Pressed?
                    done=TRUE      ' ESC Signalled A Quit
                Else        ' Not Time To Quit, Update Screen
                    DrawGLScene()     ' Draw The Scene
                    SwapBuffers(hDC)    ' Swap Buffers (Double Buffering)
                EndIf
            EndIf
 
            If (keys(VK_F1))    Then     ' Is F1 Being Pressed?
                keys(VK_F1) = FALSE     ' If So Make Key FALSE
                KillGLWindow()      ' Kill Our Current Window
                fullscreen= (fullscreen Xor 1)    ' Toggle Fullscreen / Windowed Mode
                ' Recreate Our OpenGL Window
                If (CreateGLWindow("NeHe's OpenGL Framework",640,480,16,fullscreen) = FALSE) Then
                    Return 0      ' Quit If Window Was Not Created
                EndIf
            EndIf
        EndIf
    Wend
 
    ' Shutdown
    KillGLWindow()         ' Kill The Window
    Return (msg.wParam)      ' Exit The Program
End Function
С этим окном будет раскладка переключаться с помощью ActivateKeyboardLayout(HKL_NEXT ,KLF_REORDER)
1
Pro_grammer
Модератор
6222 / 2309 / 450
Регистрация: 24.04.2011
Сообщений: 4,125
Записей в блоге: 10
30.12.2012, 15:14 16
Цитата Сообщение от stabud Посмотреть сообщение
Эти API работают для своих созданных окон, но для окон , созданных с помощью Screen и ScreenRes почему-то не катит.
Если точнее, то не для своего окна, а для своего потока. Или можно для конкретного потока, если его явно указать.
Я не спец в FB, но на Пурике это работает с любыми окнами и экранами. Выглядит так для активного окна:
PureBasic
1
2
3
HWin = GetForegroundWindow_()          ; Получаем активное окно.
Thread = GetWindowThreadProcessId_(HWin, 0); Получаем поток активного окна.
Define Lay = GetKeyboardLayout_(Thread)      ; Клавиатурная раскладка активного окна.
1
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
30.12.2012, 15:55 17
Цитата Сообщение от Pro_grammer Посмотреть сообщение
Если точнее, то не для своего окна, а для своего потока. Или можно для конкретного потока, если его явно указать.
Может не так высказался, суть была не в этом. Для своего потока не нужна эта лишняя калькуляция с вычислением хендла потока, достаточно в GetKeyboardLayout передать ноль. Получить то раскладку не проблема. Проблема как раз установить другую раскладку при использовании графического окна.

Цитата Сообщение от Pro_grammer Посмотреть сообщение
Я не спец в FB, но на Пурике это работает с любыми окнами и экранами. Выглядит так для активного окна:
Какая разница? винапи оно и в африке виапи

Вот код FB:

PureBasic
1
2
3
4
5
#Include "windows.bi"
 
Dim As HWND HWin = GetForegroundWindow()      
Dim As Integer Thread = GetWindowThreadProcessId(HWin, 0)
Dim As HKL hkl= GetKeyboardLayout(Thread)
Исчезли нижние подчеркивания у функций , да более прозрачно определения типов возвращаемых значений у функций. Ах да забыл, появилась директива подключения файла, чего так болезненно переносят пуриковчане (шутка)
1
Pro_grammer
Модератор
6222 / 2309 / 450
Регистрация: 24.04.2011
Сообщений: 4,125
Записей в блоге: 10
30.12.2012, 17:45 18
Цитата Сообщение от stabud Посмотреть сообщение
Какая разница?
Ну раз нет разницы, то почему говоришь, что не работает для окон , созданных с помощью Screen и ScreenRes?
0
stabud
122 / 49 / 1
Регистрация: 26.10.2012
Сообщений: 84
30.12.2012, 17:48 19
Quiet Snow! У меня у самого часто возникал такой вопрос, а после вашего обращения, желание найти решение лишь подогрелось. Я даже создал тему на оф. форуме FB, хотя решение нашел сам.

Вся моя беда, что я часто при просмотре винапишных функций пользуюсь справочником х.з. какого года и в нем для функции ActivateKeyboardLayout лишь один флаг KLF_REORDER. Все ленюсь заглядывать в MSDN. В реале у функции ActivateKeyboardLayout несколько возможных значений (флагов). Нужно попросту поставить флаг: KLF_SETFORPROCESS

И замена раскладки будет для всего текущего процесса, вот пример:

PureBasic
1
2
3
4
5
6
7
#Include "windows.bi"
 
Screen 1
ActivateKeyboardLayout(HKL_NEXT ,KLF_SETFORPROCESS) 'but does not change
Do
    ? Chr(GetKey)
Loop
Цитата Сообщение от Pro_grammer Посмотреть сообщение
Ну раз нет разницы, то почему говоришь, что не работает для окон , созданных с помощью Screen и ScreenRes?
Я надеюсь ответа не требуется после моего поста.
1
Pro_grammer
Модератор
6222 / 2309 / 450
Регистрация: 24.04.2011
Сообщений: 4,125
Записей в блоге: 10
30.12.2012, 19:32 20
Цитата Сообщение от stabud Посмотреть сообщение
Я надеюсь ответа не требуется после моего поста.
Теперь ясно
0
30.12.2012, 19:32
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
30.12.2012, 19:32

Приложение мгновенного обмена сообщениями, как получить список друзей
Доброго времени суток! Я работаю на C# всего нечего, но он меня заинтересовал... и я решил на тему...

Немного о FreeBasic
Чаще всего при начальном использовании какого-то языка , люди стараются выбрать простую,...

FreeBASIC и сети
Здравствуй, форум. Всё дело в том, что есть одни сетевые функции, и для этих функций Я решил...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.
Рейтинг@Mail.ru