Создаю программу считывания пикселей на экране (что-то типа экранной лупы) и в Windows 7 очень тормозит функция GetPixel

@HackerVlad · Регистрация: 10.09.2021

Студворк — интернет-сервис помощи студентам

Доброго времени суток!

Я конечно понимаю, что наверное такая тема уже была. Но всё же, помогите разобраться с функцией GetPixel.
Я написал по-быстрому маленькую программку на VB6 для считывания области экрана в квадрате 16х16 пикселей вокруг курсора мышки. Что-то типа экранной лупы. Это мне нужно для того чтобы удобно было просматривать неровности пикселей, особенно помогает для правильной вёрстки Html-страничек, очень часто мне это нужно там пикселя подгонять в CSS. Ну я и придумал такую программку, а то стандартная экранная лупа тут не особо помогает. Суть программы в том, чтобы ни только считывать квадрат области экрана, для его увлечения, но и проверки цвета каждого пикселя на экране в заданном квадрате вокруг курсора мышки.

Программа безумно простая но работает только на Win XP. В Windows 7 очень сильно тормозит функция GetPixel. Помогите изменить эту программу так чтобы она работала и в Windows 7 тоже. Наверное надо отказываться от функции GetPixel и менять на другую. Помогите пожалуйста.

Вот очень простой код моей маленькой программки.

Visual Basic
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
Option Explicit
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal Hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
 
Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
Private Sub Timer1_Timer()
    Dim h As Long
    Dim tick As Long
    Dim i As Long
    Dim i2 As Long
    Dim mouseX As Long
    Dim mouseY As Long
    Dim GetColor As Long
    Dim GetMousePos As POINTAPI
    
    tick = GetTickCount
    
    h = GetDC(0)
    Me.Cls
    
    GetCursorPos GetMousePos
    mouseX = GetMousePos.X - 8
    mouseY = GetMousePos.Y - 8
    
    For i = 0 To 15
        ' Прорисовать пиксели по горизонтали
        GetColor = GetPixel(h, mouseX + i, mouseY)
        
        ' Рисую квадратики - каждый квадратик это пиксель на экране
        Line ((i * 16), 0)-(((i + 1) * 16), 16), vbBlack, B
        Line (((i * 16) + 1), 1)-((((i + 1) * 16) - 1), 15), GetColor, BF
        
        For i2 = 0 To 14
            ' Прорисовать пиксели по вертикали
            GetColor = GetPixel(h, mouseX + i, mouseY + (i2 + 1))
            
            ' Рисую квадратики - каждый квадратик это пиксель на экране
            Line ((i * 16), ((i2 + 1) * 16))-(((i + 1) * 16), (((i2 + 1) * 16)) + 16), vbBlack, B
            Line (((i * 16) + 1), ((i2 + 1) * 16) + 1)-((((i + 1) * 16) - 1), ((((i2 + 1) * 16)) + 16) - 1), GetColor, BF
        Next
    Next
    
    ReleaseDC 0, h
    
    Debug.Print GetTickCount - tick ' В семёрке у меня 4.5 сек.
    Timer1.Enabled = False ' Интервал таймера у меня 500 млск, но увы, если 4.5 секунды в семёрке выполняется только один цикл кода, то... пока остановил таймер... Чтобы не висла система...
End Sub

@HackerVlad · 25.09.2023, 21:55 **[ТС]**

The trick, ну в этом и проблема, как я узнаю что мышь на сетке?

@The trick · 25.09.2023, 22:09

Сообщение от HackerVlad

как я узнаю что мышь на сетке?

По координатам. Ты же рисуешь эти линии.

@HackerVlad · 25.09.2023, 22:11 **[ТС]**

Или всё-таки слоёную форму сделать?

@HackerVlad · 26.09.2023, 14:52 **[ТС]**

The trick, почему ты мне не сказал, что это настолько просто? всего одна строчка кода, а я думал это сложно, поэтому у тебя спрашивал... оказывается это супер легко, просто нужно проверить являются ли координаты мыши кратным 16 и всё:

Visual Basic
1
2
3
4
5
6
7
8
9
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim GetColor As Long
    
    GetColor = Me.Point(x, y)
    
    If x <> 255 And y <> 255 And (x Mod 16) <> 0 And (y Mod 16) <> 0 Then
        Label1.Caption = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
    End If
End Sub

@HackerVlad · 26.09.2023, 15:39 **[ТС]**

Вот окончательный вариант программы:

Visual Basic
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
Option Explicit
' *----------------------------------------*
' | Программа PixelingNT                   |
' | Версия 1.0                             |
' | Copyright (c) 26.09.2023 by HackerVlad |
' | e-mail: vladislavpeshkov@ya.ru         |
' *----------------------------------------*
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As OLE_HANDLE) As OLE_HANDLE
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As OLE_HANDLE, ByVal hDC As OLE_HANDLE) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As OLE_HANDLE, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As OLE_HANDLE, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef Point As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetMem1 Lib "msvbvm60" (ByVal Src As Long, Dst As Any) As Long
 
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Dim ScreenX As Long
Dim ScreenY As Long
Dim Stopped As Boolean
Dim MouseXY As POINTAPI
 
Private Function APIColor2HtmlColor(APIColor As Long) As String
    Dim colorR As Byte
    Dim colorG As Byte
    Dim colorB As Byte
    
    GetMem1 VarPtr(APIColor), colorR
    GetMem1 VarPtr(APIColor) + 1, colorG
    GetMem1 VarPtr(APIColor) + 2, colorB
    
    APIColor2HtmlColor = "#" & IIf(Len(Hex(colorR)) = 2, Hex(colorR), "0" & Hex(colorR)) & IIf(Len(Hex(colorG)) = 2, Hex(colorG), "0" & Hex(colorG)) & IIf(Len(Hex(colorB)) = 2, Hex(colorB), "0" & Hex(colorB))
End Function
 
Private Sub Form_Click()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
       .SetText Label1.Caption
       .PutInClipboard
    End With
End Sub
 
Private Sub Form_Load()
    WindowTopMost hwnd, True
    PositionWindow hwnd, mRightBottom
    
    ScreenX = (Screen.Width / Screen.TwipsPerPixelX)
    ScreenY = (Screen.Height / Screen.TwipsPerPixelY)
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim GetColor As Long
    Dim LabelString As String
    
    GetColor = Me.Point(x, y)
    
    If x <> 255 And y <> 255 And (x Mod 16) <> 0 And (y Mod 16) <> 0 Then
        LabelString = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
        
        If Label1.Caption <> LabelString Then
            Label1.Caption = LabelString
        End If
    End If
End Sub
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        Unload Me
    End If
End Sub
 
Private Sub Label1_Click()
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Label1_DblClick()
    PositionWindow hwnd, mRightBottom
End Sub
 
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call ReleaseCapture
    Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Timer1_Timer()
    Dim hDC As OLE_HANDLE
    Dim tPT As POINTAPI
    Dim mouseX As Long
    Dim mouseY As Long
    Dim lN As Long
    
    If Stopped = False Then
        GetCursorPos tPT
        
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Label1.Caption = tPT.x & " x " & tPT.y
            hDC = GetDC(0)
            
            If hDC Then
                If (tPT.x - 8) >= 0 Then
                    If tPT.x >= ScreenX - 8 Then
                        Me.Cls
                        mouseX = ScreenX - 8
                    Else
                        mouseX = tPT.x - 8
                    End If
                End If
                If (tPT.y - 8) >= 0 Then
                    If tPT.y > ScreenY - 8 Then
                        Me.Cls
                        mouseY = ScreenY - 8
                    Else
                        mouseY = tPT.y - 8
                    End If
                End If
                
                StretchBlt Me.hDC, 0, 0, 256, 256, hDC, mouseX, mouseY, 16, 16, vbSrcCopy
                
                ReleaseDC 0, hDC
                Me.Refresh
            End If
        End If
    End If
End Sub
 
Private Sub Timer2_Timer()
    Dim tPT As POINTAPI
    Dim lN  As Long
    
    GetCursorPos tPT
    
    If GetAsyncKeyState(17) And GetAsyncKeyState(91) Or GetAsyncKeyState(17) And GetAsyncKeyState(92) Then
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Timer3.Enabled = True
            Timer2.Enabled = False
            
            Stopped = Not (Stopped)
            Timer1.Enabled = Not (Timer1.Enabled)
            
            If Stopped = True Then
                MouseXY = tPT
                Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
                
                For lN = 0 To 15
                    Me.Line (0, lN * 16)-Step(256, 0), vbBlack
                    Me.Line (lN * 16, 0)-Step(0, 256), vbBlack
                Next
                
                Me.Line (255, 0)-(255, 255), vbBlack
                Me.Line (0, 255)-(256, 255), vbBlack
            End If
            
            Exit Sub
        End If
    End If
    
    If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
        If Stopped = True Then
            Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
        End If
    End If
End Sub
 
Private Sub Timer3_Timer()
    Timer3.Enabled = False
    Timer2.Enabled = True
End Sub

@HackerVlad · 26.09.2023, 16:30 **[ТС]**

Исправил мелкие ошибки, вот новый листинг программы (просьба к администрации так же заменить и в готовых решениях):

Visual Basic
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
Option Explicit
' *----------------------------------------*
' | Программа PixelingNT                   |
' | Версия 1.0                             |
' | Copyright (c) 26.09.2023 by HackerVlad |
' | e-mail: vladislavpeshkov@ya.ru         |
' *----------------------------------------*
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As OLE_HANDLE) As OLE_HANDLE
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As OLE_HANDLE, ByVal hDC As OLE_HANDLE) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As OLE_HANDLE, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As OLE_HANDLE, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef Point As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetMem1 Lib "msvbvm60" (ByVal Src As Long, Dst As Any) As Long
 
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Dim ScreenX As Long
Dim ScreenY As Long
Dim Stopped As Boolean
Dim MouseXY As POINTAPI
 
Private Function APIColor2HtmlColor(APIColor As Long) As String
    Dim colorR As Byte
    Dim colorG As Byte
    Dim colorB As Byte
    
    GetMem1 VarPtr(APIColor), colorR
    GetMem1 VarPtr(APIColor) + 1, colorG
    GetMem1 VarPtr(APIColor) + 2, colorB
    
    APIColor2HtmlColor = "#" & IIf(Len(Hex(colorR)) = 2, Hex(colorR), "0" & Hex(colorR)) & IIf(Len(Hex(colorG)) = 2, Hex(colorG), "0" & Hex(colorG)) & IIf(Len(Hex(colorB)) = 2, Hex(colorB), "0" & Hex(colorB))
End Function
 
Private Sub Form_Click()
    Dim PutSetText As String
    
    PutSetText = Label1.Caption
    
    If Len(PutSetText) > 0 Then
        PutSetText = Replace(PutSetText, "&&H", "&H")
        
        With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
           .SetText PutSetText
           .PutInClipboard
        End With
    End If
End Sub
 
Private Sub Form_Load()
    WindowTopMost hwnd, True
    PositionWindow hwnd, mRightBottom
    
    ScreenX = (Screen.Width / Screen.TwipsPerPixelX)
    ScreenY = (Screen.Height / Screen.TwipsPerPixelY)
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim GetColor As Long
    Dim LabelString As String
    
    GetColor = Me.Point(x, y)
    
    If Stopped = True Then
        If x <> 255 And y <> 255 And (x Mod 16) <> 0 And (y Mod 16) <> 0 Then
            LabelString = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
            
            If Label1.Caption <> LabelString Then
                Label1.Caption = LabelString
            End If
        End If
    Else
        LabelString = "VB: (&&H" & Hex(GetColor) & "), Html: (" & APIColor2HtmlColor(GetColor) & ")"
        
        If Label1.Caption <> LabelString Then
            Label1.Caption = LabelString
        End If
    End If
End Sub
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        Unload Me
    End If
End Sub
 
Private Sub Label1_Click()
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Label1_DblClick()
    PositionWindow hwnd, mRightBottom
End Sub
 
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call ReleaseCapture
    Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Stopped = True Then
        Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
    End If
End Sub
 
Private Sub Timer1_Timer()
    Dim hDC As OLE_HANDLE
    Dim tPT As POINTAPI
    Dim mouseX As Long
    Dim mouseY As Long
    Dim lN As Long
    
    If Stopped = False Then
        GetCursorPos tPT
        
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Label1.Caption = tPT.x & " x " & tPT.y
            hDC = GetDC(0)
            
            If hDC Then
                If (tPT.x - 8) >= 0 Then
                    If tPT.x >= ScreenX - 8 Then
                        Me.Cls
                        mouseX = ScreenX - 8
                    Else
                        mouseX = tPT.x - 8
                    End If
                End If
                If (tPT.y - 8) >= 0 Then
                    If tPT.y > ScreenY - 8 Then
                        Me.Cls
                        mouseY = ScreenY - 8
                    Else
                        mouseY = tPT.y - 8
                    End If
                End If
                
                StretchBlt Me.hDC, 0, 0, 256, 256, hDC, mouseX, mouseY, 16, 16, vbSrcCopy
                
                ReleaseDC 0, hDC
                Me.Refresh
            End If
        End If
    End If
End Sub
 
Private Sub Timer2_Timer()
    Dim tPT As POINTAPI
    Dim lN  As Long
    
    GetCursorPos tPT
    
    If GetAsyncKeyState(17) And GetAsyncKeyState(91) Or GetAsyncKeyState(17) And GetAsyncKeyState(92) Then
        If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
            Timer3.Enabled = True
            Timer2.Enabled = False
            
            Stopped = Not (Stopped)
            Timer1.Enabled = Not (Timer1.Enabled)
            
            If Stopped = True Then
                MouseXY = tPT
                Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
                
                For lN = 0 To 15
                    Me.Line (0, lN * 16)-Step(256, 0), vbBlack
                    Me.Line (lN * 16, 0)-Step(0, 256), vbBlack
                Next
                
                Me.Line (255, 0)-(255, 255), vbBlack
                Me.Line (0, 255)-(256, 255), vbBlack
            End If
            
            Exit Sub
        End If
    End If
    
    If WindowFromPoint(tPT.x, tPT.y) <> Me.hwnd Then ' Если под курсором мыши не моё окно
        If Stopped = True Then
            Label1.Caption = "Stopped (" & MouseXY.x & " x " & MouseXY.y & ")"
        End If
    End If
End Sub
 
Private Sub Timer3_Timer()
    Timer3.Enabled = False
    Timer2.Enabled = True
End Sub

@xxdoc · 05.10.2023, 15:52

if i used win10 dpi set 120% 。may be not show good

@HackerVlad · 05.10.2023, 18:14 **[ТС]**

xxdoc, честно, у меня нету десятки, и я не пробовал в этой винде, но в семёрке я не могу попробовать 120% в семёрке только 125, и 150 по моему процентов есть.

Добавлено через 6 минут
xxdoc, я только что посмотрел на 125%, да, вы правы, отображается не очень, так как растягивает форму, но не растягивает изображение, тут можно конечно запретить растягивание формы при 125% а можно увеличивать а можно ничего не делать... хз короче

Добавлено через 10 секунд
у меня всегда 100% у меня всё норм.

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

Добавлено через 27 секунд
я лично не работаю в увеличенных масштабах экрана по 125 или по 150 процентов поэтому у меня всё норм

@HackerVlad · 10.10.2023, 11:34 **[ТС]**

Сообщение от xxdoc

if i used win10 dpi set 120% 。may be not show good

Ну что, попробуем исправить тогда этот мелкий недостаток.

Добавлено через 56 минут
Для 125% подправил, для 150% надо ещё файл манифеста прикладывать.

@HackerVlad · 10.10.2023, 11:36 **[ТС]**

Новая версия:

Visual Basic
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
Private Sub Form_Load()
    Dim ABD As APPBARDATA, Ret As Long
    Dim hPanel As Integer
    Dim gPanel As Integer
    
    ScreenX = (Screen.Width / Screen.TwipsPerPixelX)
    ScreenY = (Screen.Height / Screen.TwipsPerPixelY)
    
    ' Предотвратить растягивание формы в других DPI
    If IsScreenZoom > 100 Then
        Me.Width = 256 * Screen.TwipsPerPixelX
        Me.Height = 273 * Screen.TwipsPerPixelY
        Label1.Top = 256
        Label1.Left = 0
        Label1.Width = 256
        Label1.Height = Me.Height - Label1.Top
        Label1.Font = GetSystemFontName(MessageFont)
        
        If IsScreenZoom > 125 Then
            Label1.FontSize = 7
        Else
            Label1.FontSize = 9
        End If
    End If
    
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
    
    ' Математические расчёты для центрирования формы в правом нижнем углу экрана, в соответствии с таскбаром
    SHAppBarMessage ABM_GETTASKBARPOS, ABD
    Ret = SHAppBarMessage(ABM_GETSTATE, ABD)
    If Trim(Str(ABD.rc.Top)) > 0 Then hPanel = (Trim(Str(ABD.rc.Bottom)) - Trim(Str(ABD.rc.Top))) * Screen.TwipsPerPixelX
    If Trim(Str(ABD.rc.Left)) > 0 Then gPanel = (Trim(Str(ABD.rc.Right)) - Trim(Str(ABD.rc.Left))) * Screen.TwipsPerPixelX
    
    Me.Left = Screen.Width - Me.Width - gPanel
    Me.Top = Screen.Height - Me.Height - hPanel
End Sub

Там в архиве вместе с манифестом.

@xxdoc · 13.10.2023, 05:07

work ok.thanks.

Новые блоги и статьи Все статьи Все блоги /
Эксперимент с картинкой-обложкой на CodinGame Adler 10.07.2026 Решил на днях провести эксперимент. У меня есть аккаунт на CodinGame, ТОП-3 по РФ среди 2200 участников (в разделе соревнования по программированию ИИ-ботов). Там есть обложка, куда можно влепить. . .	После бана на Пикабу не работает авторизация аккаунта с Яндекса. Hrethgir 09.07.2026 В частности https:/ / auto. ru/ logbook/ zapret-na-vozhdenie-posle-65-let_1cf28789-07b4-4c75-a2f7-4cd4edf9deeb тут хотел оставить комментарий такой Зрите в корень - монополизация на разработку программ. . .	GitDOS: Когда я решил скрестить MS-DOS, GitHub и Claude MaGz GoLd 08.07.2026 Привет, Киберфорум! Хочу поделиться своим проектом, который, надеюсь, вас заинтересует. GitDOS — это веб-приложение, которое позволяет запускать DOS в браузере с тремя крутыми фичами: диски живут в. . .	Учебный мини "цифровой двойник" = (Сервер = Java + Flask_питон )+(3D = Гугловскаая 4T nvideo + google colab) +( WMS = Odoo на Docker) anaschu 07.07.2026 Увидел в требованиях к вакансии создателя имитационных моделей связку (REst + Api + WMS + Anylogic + питон + 3D Nvideo), и решил посмотреть, что это такое. Из этого всего я работал более менее. . .
Море в объективе kumehtar 06.07.2026 Хотел написать много проникновенных слов, но передумал. Оно само - говорит. Кто слышит тот слышит.	Doom для терминала без стрельбы и монстров. 3D Raycasting на ascii. dcc0 05.07.2026 Попросил нейронную сеть deepai. org написать рейкастинг 3D с библиотекой ncurses для Linux. Чтобы можно было ходить на стрелочки. Чтобы стены были отрисованы символами. Справилась. Первый вариант. . .	Установка статуса документа по условию Maks 05.07.2026 Алгоритм из решения ниже реализован на нетиповом документе "НарядПутевка" разработанного в КА2. Задача: в табличной части "Материалы" документа при записи автоматически устанавливать статус. . .	Сезонность и суточность закисления почв anaschu 04.07.2026 200 часов это все равно моловато. Есть ситуации, но нестандартные, когда смена происходит за 5 лет. Но обычно это 50 лет и более. Наверное, закисление почвы происходит сезонно в средней. . .

@HackerVlad Вернулся 1750 / 646 / 45 Регистрация: 10.09.2021 Сообщений: 2,797
	25.09.2023, 21:55 [ТС]
	The trick, ну в этом и проблема, как я узнаю что мышь на сетке? 0

@HackerVlad Вернулся 1750 / 646 / 45 Регистрация: 10.09.2021 Сообщений: 2,797
	25.09.2023, 22:11 [ТС]
	Или всё-таки слоёную форму сделать? 0

@xxdoc 7 / 7 / 0 Регистрация: 10.07.2015 Сообщений: 69
	05.10.2023, 15:52
	if i used win10 dpi set 120% 。may be not show good 0

@HackerVlad Вернулся 1750 / 646 / 45 Регистрация: 10.09.2021 Сообщений: 2,797
	05.10.2023, 18:14 [ТС]
	xxdoc, честно, у меня нету десятки, и я не пробовал в этой винде, но в семёрке я не могу попробовать 120% в семёрке только 125, и 150 по моему процентов есть. Добавлено через 6 минут xxdoc, я только что посмотрел на 125%, да, вы правы, отображается не очень, так как растягивает форму, но не растягивает изображение, тут можно конечно запретить растягивание формы при 125% а можно увеличивать а можно ничего не делать... хз короче Добавлено через 10 секунд у меня всегда 100% у меня всё норм. Добавлено через 1 минуту я эту программу писал вообще для себя чисто, и даже не планировал ей делиться, потом вдруг подумал что может кому-то ещё надо и решил выложить, каждый сам под себя может переписать и настроить если ему надо Добавлено через 27 секунд я лично не работаю в увеличенных масштабах экрана по 125 или по 150 процентов поэтому у меня всё норм 0

@xxdoc 7 / 7 / 0 Регистрация: 10.07.2015 Сообщений: 69
	13.10.2023, 05:07
	work ok.thanks. 1