Мои примеры

@Антихакер32 · Регистрация: 06.01.2014

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

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

Итак:
"регистрация компонента"

Зарегить компонент можно несколькими способами
один из них хочу предоставить здесь

Добавлено через 4 минуты
Добавлю в той библиотеке Dialogs, существует еще несколько классов
но это можно узнать если подключить компонент через References

@Антихакер32 · 02.09.2014, 10:56 **[ТС]**

Сообщение от The trick

и к тому же с правильным инкрементом счетчика ссылок

Тоесть вы хотите сказать, что можно получить неправильную ссылку..
что это значит?, копию экземляра ?

@The trick · 02.09.2014, 10:58

Сообщение от Антихакер32

Тоесть вы хотите сказать, что божно получить неправильную ссылку..
что это значит?, копию экземляра ?

Я тебе уже говорил много раз - возьми книжку по работе COM/ActiveX и почитай, буквально во введении все будет написано как работать с объектами.

@Антихакер32 · 02.09.2014, 17:31 **[ТС]**

Сообщение от The trick

COM/ActiveX и почитай, буквально во введении все будет написано как работать с объектами.

Ну с этим можно позже разобраться, а идея собственно в том,
что сторонней прогой можно пользовать, данный объект

Добавлено через 6 часов 1 минуту
Усовершенствовал !
теперь можно одинаково использовать этот класс и для форм и для UserControl-..ов

напимер так:

Visual Basic
1
2
3
Private Sub Form_Load()
    Choose(1, New UGObj).FrameRePaint Controls
End Sub

или так:

Visual Basic
1
2
3
Private Sub UserControl_Show()
    Choose(1, New UGObj).FrameRePaint Controls
End Sub

или так тоже в обоих случаях:

Visual Basic
1
2
3
Private Sub UserControl_Show()
    Choose(1, New UGObj).FrameRePaint [_Default]
End Sub

(UGObj - это у меня класс так называется (Абгрейд VB), в последствии это
будет спец DLL-ка

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
Option Explicit
'Класс для работы с объектами
'Исправление некоректного отображения, путем внедрения
'в контейнер фрейма, пикчурбокса, и его детей
'
Private Const cLabName = "FrameRePaint_Label_"
Private Const cPicName = "FrameRePaint_Picture_"
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Target As Any, ByRef Source As Any, ByVal Length As Long)
 
Public Function FrameRePaint(Controls As Object) As Long
    'Добавление пикчура в каждый контейнер фрейма
    'Арг: Controls - коллекция объектов
    'возвращает число действий
    On Error GoTo 1001
    Dim Item As Object, Child As Object, Pic As Object, Lab As Object
    Dim s$, FLeft&, FTop&, bFrame As Boolean, IDParent&, hWndCh&
    FLeft = Screen.TwipsPerPixelX * 3
    IDParent = ObjPtr(Controls)
    s = cLabName & IDParent
    If Not ControlExists(Controls, s) Then
        Set Lab = Controls.Add("VB.Label", s): Lab.AutoSize = True
    Else: Set Lab = Controls(s)
    End If
    For Each Item In Controls
        If TypeName(Item) = "Frame" Then
            s = cPicName & IDParent & "_" & Item.hWnd
            If Not ControlExists(Controls, s) Then
                Set Pic = Controls.Add("VB.PictureBox", s, Item)
                FrameRePaint = FrameRePaint + 1
                With Pic
                    .BorderStyle = 0: .BackColor = Item.BackColor: .Visible = 1
                End With
            Else: Set Pic = Controls(s)
            End If
            Set Lab.Font = Item.Font: Lab.Caption = Item.Caption: FTop = Lab.Height / 1.2
            Pic.Move FLeft, FTop, Item.Width - FLeft * 2, Item.Height - FTop - FLeft
            For Each Child In Controls
                hWndCh = Container_hWnd(Child)
                If hWndCh > 0 And hWndCh = Item.hWnd And Child.Name <> Pic.Name Then
                    Set Child.Container = Pic: MoveObjPos Child, -FLeft, -FTop
    End If: Next: End If: Next
1001
End Function
 
Public Function Container_hWnd(Obj As Object) As Long
    'Возвращает hWnd контейнера
    On Error Resume Next: Container_hWnd = Obj.Container.hWnd
End Function
 
Public Function ControlExists(Controls As Object, ByVal Name$) As Boolean
    'Возвращает утверждение о существующем имени контрола в группе Parent
    On Error Resume Next: ControlExists = Not IsError(Controls(Name))
End Function
 
Public Function MoveObjPos(Obj As Object, X&, Y&)
    'Сдвигает объект на указанные значения, например (+|-)X, (+|-)Y
    On Error Resume Next
    Obj.Move Obj.Left + X, Obj.Top + Y
    If Err.Number = 438 Then
        'Исключение для объекта Line, имеющего два конца
        With Obj
            .X1 = .X1 + X: .X2 = .X2 + X
            .Y1 = .Y1 + Y: .Y2 = .Y2 + Y
    End With: End If
End Function
 
Public Function PtrObj(ByVal Pointer As Long) As Object
    'Возврат объекта по указателю
    'Арг: Указатель в памяти вызывается так ObjPtr(Obj)
    Dim SoftRef As Object
    On Error Resume Next
    If Pointer = 0 Then Exit Function
    RtlMoveMemory SoftRef, Pointer, 4 'Получить ссылку на объект
    Set PtrObj = SoftRef
    RtlMoveMemory SoftRef, 0&, 4 'Уничтожить нелегальную ссылку
End Function

Добавлено через 5 минут
Кстати, если использовать этот класс в UserControl-..ах, то при заброске его на форму..
все выглядит ровно, сразу и моментально

@Антихакер32 · 03.09.2014, 01:07 **[ТС]**

Халяву одним словом раздаю, в интернете такого нет ..

Добавлено через 7 часов 31 минуту
Золотая коллекция классов

Таймер - класс для создания множества своих таймеров
ToolTip - Позволяет создавать подсказки с различными стилями
Класс исправления манифеста и работы с объектами

Таймер

Модуль

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
Option Explicit
'Модуль для реализации таймеров
'© Антихакер32
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Dim Dic As Object
 
Sub StartTimer(ClassObj As Object, RaiseObject As Object, ProcName$, Interval&)
    On Error Resume Next: If IsError(ClassObj.gTmr) Then Exit Sub
    If Dic Is Nothing Then Set Dic = CreateObject("scripting.dictionary"): Dic.CompareMode = 1
    ClassObj.gTmr = SetTimer(0, 0, Interval, AddressOf TimerProg)
    Dic.Add CStr(ClassObj.gTmr), Array(ClassObj, RaiseObject, ProcName)
End Sub
 
Sub TimerProg(ByVal hWnd As Long, ByVal msg As Long, ByVal idEvent As Long, ByVal TimeSys As Long)
    Dim v: On Error GoTo ERRR
    For Each v In Dic.keys
        If Dic(v)(0) Is Nothing Then
            EndTimer v
        ElseIf idEvent = Dic(v)(0).gTmr Then
            CallByName Dic(v)(1), Dic(v)(2), VbMethod
        End If
    Next: Exit Sub
ERRR:
    Debug.Print "errr"
End Sub
 
Sub EndTimer(ByVal VarTMR&)
    On Error Resume Next
    KillTimer 0, VarTMR
    Dic.Remove (CStr(VarTMR))
End Sub

Класс

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
Option Explicit
'Класс ТАЙМЕР
'© Антихакер32
Public gTmr&
Dim b As Boolean, mEnabled As Boolean
Dim mRaiseObject As Object, mProcName$, mInterval&
 
Public Property Get Interval() As Long
    'Получить значение Interval
    Interval = mInterval
End Property
 
Public Sub StartTimer(RaiseObject As Object, ProcName$, Interval&)
    'Запускает таймер
    'Арг: Объект с вызываемой процедурой // имя процедуры // интервал
    '*Примечание, имя процедуры должно быть объявленно глобально
    
    If gTmr > 0 Then EndTimer gTmr
    Set mRaiseObject = RaiseObject
    mProcName = ProcName
    Me.Interval = Interval
End Sub
 
Public Property Let Interval(ByVal vNewValue As Long)
    'Изменение интервала ускорения таймера этого класса
    b = Not (mRaiseObject Is Nothing) And Len(mProcName)
    If b And mInterval <> vNewValue And vNewValue > 0 Then
        If gTmr > 0 Then mTimer.EndTimer gTmr
        mTimer.StartTimer Me, mRaiseObject, mProcName, vNewValue
    ElseIf gTmr > 0 And vNewValue = 0 Then mTimer.EndTimer gTmr
    End If: mInterval = vNewValue
End Property
 
Public Property Get Enabled() As Boolean
    'Получить значение Enabled
    Enabled = mEnabled
End Property
 
Public Property Let Enabled(ByVal vNewValue As Boolean)
    'Включение или остановка действующего таймера этого класса
    b = Not (mRaiseObject Is Nothing) And Len(mProcName)
    If vNewValue Then
        mTimer.EndTimer gTmr
        mTimer.StartTimer Me, mRaiseObject, mProcName, mInterval
    Else: mTimer.EndTimer gTmr
    End If: mEnabled = vNewValue
End Property
 
Private Sub Class_Terminate()
    'Завершение таймера этого класса
    If gTmr Then EndTimer gTmr
End Sub

Шарик-подсказка

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
Option Explicit
'
'ToolTip - Позволяет создавать подсказки с различными стилями
'© Антихакер32
'
'----------------------------------------------------------[ Enums ]
Public Enum StyleEnum
    [Стиль страндарт] = 0
    [Стиль шарик] = 1
End Enum
 
Public Enum DelayTimeConstants 'Константы времени задержки
    [Задержка по умолчанию] = 0
    [Повторный просмотр] = 1
    [Задержка показа] = 2
    [Начальная задержка] = 3
End Enum
 
Public Enum IconsConst 'Отображение иконок
    [Без значка] = 0
    [Важная информация] = 1
    [Восклицательный знак] = 2
    [Знак ошибки] = 3
    [Знак вопроса] = 7
End Enum
 
'----------------------------------------------------------[ Types ]
Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Boom As Long
End Type
 
Private Type TOOLINFO
    lSize As Long
    lFlags As Long
    lHwnd As Long
    lId As Long
    lpRect As Rect
    hInstance As Long
    lpStr As String
    lParam As Long
End Type
 
Private Type POINTAPI
    X As Long
    Y As Long
End Type
'----------------------------------------------------------[ Const ]
Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000
Private Const HWND_TOPMOST = -1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
Private Const TTF_SUBCLASS = &H10
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_GETDELAYTIME = (WM_USER + 21)
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_BALLOON = &H40
Private Const TTS_NOPREFIX = &H2
'----------------------------------------------------------[ WinApi ]
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As Rect) 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 SendMessageT Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'----------------------------------------------------------[ Varibales ]
Private mTT_hWnd As Long
Private mObj_hWnd As Long
Private mToolInfo As TOOLINFO
Dim mTimer As New UGTimer
 
Public Sub TTMonitor()
    'Мониторинг выхода за квадрат
    Dim p As POINTAPI
    If mObj_hWnd = 0 Then Exit Sub
    GetCursorPos p
    If mObj_hWnd <> WindowFromPoint(p.X, p.Y) Then
        If mTT_hWnd Then DestroyWindow mTT_hWnd 'Уничтожение при условии выхода за квадрат
        mObj_hWnd = 0
        mTimer.Interval = 0
    End If
End Sub
 
 
Public Function ShowTT(hWnd, Optional Title$, Optional Text$, Optional ByVal Icon As IconsConst, Optional Style As StyleEnum = [Стиль шарик], Optional DelayInitial& = 1, Optional DelayShow& = 10000, _
Optional DelayReshow& = 10000, Optional MonitoringSquare As Boolean = True) As Boolean
    'Запуск подсказки
    Const SleepInterval = 100 'интервал паузы мониторинга
    Dim lpRect As Rect
    Dim lWinStyle As Long
    On Error GoTo ERRR
    If mTT_hWnd Then DestroyWindow mTT_hWnd 'Уничтожение прежнего тултипа вызванного этим классом
    lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
 
    If Style = [Стиль шарик] Then 'создать стиль шарика по желанию
        lWinStyle = lWinStyle Or TTS_BALLOON
    End If
 
    If hWnd Then 'Родительский контрол должен быть задан первым
        mObj_hWnd = hWnd
        mTT_hWnd = CreateWindowEx(0&, TOOLTIPS_CLASSA, vbNullString, lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, _
        CW_USEDEFAULT, CW_USEDEFAULT, hWnd, 0&, App.hInstance, 0&)
        'сделать нашу подсказку "поверх всех окон"
        SetWindowPos mTT_hWnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
        GetClientRect hWnd, lpRect 'получить квадрат родительского контрола
 
        With mToolInfo 'теперь наши подсказки в структуре
            .lFlags = TTF_SUBCLASS
            .lHwnd = hWnd
            .lId = 0
            .hInstance = App.hInstance
            .lpStr = Text 'ALREADY SET
            .lpRect = lpRect
        End With
        SendMessage mTT_hWnd, TTM_ADDTOOLA, 0&, mToolInfo 'добавить структуру подсказки
 
        If Title <> vbNullString Then 'если мы хотим, чтобы был заголовок или значок
            SendMessage mTT_hWnd, TTM_SETTITLE, Icon, ByVal Title
        End If
        SendMessage mTT_hWnd, TTM_SETMAXTIPWIDTH, 0&, 0 'Значение многострочности
        DelayTime([Начальная задержка]) = DelayInitial 'Интервал времени для возникновения (мс)
        DelayTime([Задержка показа]) = DelayShow 'Интервал времени отображения (мс)
        DelayTime([Повторный просмотр]) = DelayReshow
        ShowTT = True 'Бул готовности
        If MonitoringSquare Then 'Проверять квадрат объекта
            mTimer.StartTimer Me, "TTMonitor", 100
        End If
 
    End If
ERRR:
    ShowTT = False 'Бул ошибки !
End Function
 
Private Property Get DelayTime(dwType As DelayTimeConstants) As Long
    If mTT_hWnd = 0 Then Exit Property
    DelayTime = SendMessageT(mTT_hWnd, TTM_GETDELAYTIME, (dwType And [Начальная задержка]), 0&)
End Property
 
Public Property Let DelayTime(dwType As DelayTimeConstants, dwMilliSecs As Long)
    If mTT_hWnd = 0 Then Exit Property
    Call SendMessageT(mTT_hWnd, TTM_SETDELAYTIME, (dwType And [Начальная задержка]), ByVal dwMilliSecs)
End Property
 
Private Sub Class_Terminate()
    If mTT_hWnd <> 0 Then DestroyWindow mTT_hWnd
End Sub

@Антихакер32 · 03.09.2014, 08:51 **[ТС]**

Корректор манифеста

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
Option Explicit
'Класс для работы с объектами
'Исправление некоректного отображения, путем внедрения
'в контейнер фрейма, пикчурбокса, и его детей
'© Антихакер32
'
Private Const cLabName = "FrameRePaint_Label_"
Private Const cPicName = "FrameRePaint_Picture_"
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Target As Any, ByRef Source As Any, ByVal Length As Long)
 
Public Function FrameRePaint(Controls As Object) As Long
    'Добавление пикчура в каждый контейнер фрейма
    'Арг: Controls - коллекция объектов
    'возвращает число действий
    On Error GoTo 1001
    Dim Item As Object, Child As Object, Pic As Object, Lab As Object
    Dim s$, FLeft&, FTop&, bFrame As Boolean, IDParent&, hWndCh&
    FLeft = Screen.TwipsPerPixelX * 3
    IDParent = ObjPtr(Controls)
    s = cLabName & IDParent
    If Not ControlExists(Controls, s) Then
        Set Lab = Controls.Add("VB.Label", s): Lab.AutoSize = True
    Else: Set Lab = Controls(s)
    End If
    For Each Item In Controls
        If TypeName(Item) = "Frame" Then
            s = cPicName & IDParent & "_" & Item.hWnd
            If Not ControlExists(Controls, s) Then
                Set Pic = Controls.Add("VB.PictureBox", s, Item)
                With Pic: .BorderStyle = 0: .BackColor = Item.BackColor: .Visible = 1: End With
            Else: Set Pic = Controls(s)
            End If: FrameRePaint = FrameRePaint + 1
            Set Lab.Font = Item.Font: Lab.Caption = Item.Caption: FTop = Lab.Height / 1.2
            Pic.Move FLeft, FTop, Item.Width - FLeft * 2, Item.Height - FTop - FLeft
            For Each Child In Controls
                hWndCh = Container_hWnd(Child)
                If hWndCh > 0 And hWndCh = Item.hWnd And Child.Name <> Pic.Name Then
                    Set Child.Container = Pic: MoveObjPos Child, -FLeft, -FTop
    End If: Next: End If: Next
1001
End Function
 
Public Function Container_hWnd(Obj As Object) As Long
    'Возвращает hWnd контейнера
    On Error Resume Next: Container_hWnd = Obj.Container.hWnd
End Function
 
Public Function ControlExists(Controls As Object, ByVal Name$) As Boolean
    'Возвращает утверждение о существующем имени контрола в группе Parent
    On Error Resume Next: ControlExists = Not IsError(Controls(Name))
End Function
 
Public Function MoveObjPos(Obj As Object, X&, Y&)
    'Сдвигает объект на указанные значения, например (+|-)X, (+|-)Y
    On Error Resume Next
    Obj.Move Obj.Left + X, Obj.Top + Y
    If Err.Number = 438 Then
        'Исключение для объекта Line, имеющего два конца
        With Obj: .X1 = .X1 + X: .X2 = .X2 + X: .Y1 = .Y1 + Y: .Y2 = .Y2 + Y
    End With: End If
End Function
 
Public Function PtrObj(ByVal Pointer As Long) As Object
    'Возврат объекта по указателю
    'Арг: Указатель в памяти вызывается так ObjPtr(Obj)
    Dim SoftRef As Object
    On Error Resume Next: If Pointer = 0 Then Exit Function
    RtlMoveMemory SoftRef, Pointer, 4 'Получить ссылку на объект
    Set PtrObj = SoftRef
    RtlMoveMemory SoftRef, 0&, 4 'Уничтожить нелегальную ссылку
End Function

Пример использования ! ✰

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
Option Explicit
'Пример использования таймера на VBA
Dim tmr1 As UGTimer
Dim tmr2 As UGTimer
Dim tt As New UGTT
'2 строчки для манифеста
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Sub Form_Initialize(): InitCommonControls: End Sub
 
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Const s = "Если ты легко и просто //выбил двери головой? //Значит ты тупой и толстый //а не сильный и крутой!!!", r = "//"
    tt.ShowTT Command1.hWnd, "Привет", Replace(s, r, vbCrLf), [Важная информация]
End Sub
 
Public Sub RaiseTimer1()
    Static i&: i = i + 1
    Debug.Print "*" & i & "*"
    'Разные ускорения
    If i > 3 Then tmr1.Interval = 100
    If i > 30 Then tmr1.Interval = 1000
    If i > 32 Then tmr1.Enabled = False
End Sub
 
Public Sub RaiseTimer2()
    Static i&: i = i + 1
    Debug.Print Chr(i + 33);
    If i > 128 Then tmr2.Enabled = False
End Sub
Private Sub Form_Load()
    'Создаём 2 таймера, для особой наглядности
    Set tmr1 = New UGTimer
    Set tmr2 = New UGTimer
    'Вносим аргументы, какая наша процедура будет
    'мониторинговой, тоесть таймер ее будет вызывать
    tmr1.StartTimer Me, "RaiseTimer1", 1000
    tmr2.StartTimer Me, "RaiseTimer2", 100
    Choose(1, New UGObj).FrameRePaint [_Default]
End Sub

Картинка:

там в дебагере, паралельно программа пишет с разными скоростями всякую ерунду

Исходники: >> GoldSoft.rar (19.7 Кб) <<

Добавлено через 6 часов 29 минут
Вчера уже под утро (по моему времени) выложил.
Торопился, и не рассказал:, с классом таймера, я пересмотрел ранее созданные проекты
например для шарик-подсказки раньше я использовал бесконечный цикл, с условием выхода за квадрат, теперь-же, я использую класс таймера, в классе UGTT

Visual Basic
1
2
3
        If MonitoringSquare Then 'Проверять квадрат объекта
            mTimer.StartTimer Me, "TTMonitor", 100
        End If

фишка вот в чем, что это не OCX, и для использования в проектах, например
в макросах VBA, где нужно паралельно и лист видеть, и в процедуре чтото выполнялось.
И таких процедур можно запустить сколько угодно

@Антихакер32 · 09.09.2014, 23:04 **[ТС]**

Большая библиотека UGVB6

Нативная DLL, которой не требуется регистрация в системе
и которая умеет ! ✰

Определять и менять расскладку клавиатуры
Многократно создавать хуки
Вызывать процедуры с периодичностью (как в таймере)
Процедурно вызывать окно папки, и окно выбора файлов (помня прежнее место)
Делать красивую, многострочную подсказку, при наведении или нажатии на контрол
Исправлять манифест, и многое, многое, многое...

кроме того, задокументированна..
каждая процедура, каждое свойство подробно описанно
и если её подключить через References, то всё можно увидеть

используется как и обычная API-шная функция:
Private Declare Function UGCollection Lib "UGVB6" () As Collection

в архиве, что я выложил, многочисленные примеры её использования

Архив:
UgExport.rar (43.3 Кб)

Добавлено через 2 минуты
Модуль формы для демонстрации:

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
Option Explicit
'
'#Const References = 1'Если эта библиотека подключеня через References _
то эту строку, можно раскоментировать
#If References Then
    Dim ugf As New UGFun
    Dim ugh As New UGHook
    Dim ugo As New UGObj
    Dim ugtmr As New UGTimer
    Dim ugt As New UGTT
#Else
    'Вариант деклараций, если ничего не подключенно
    Private Const WM_NCLBUTTONDOWN = &HA1
    Private Const WM_LBUTTONDOWN = &H201
    Private Const HTCAPTION = 2
    Public ugf, ugh, ugo, ugtmr, ugt
    Private Declare Function UGCollection Lib "UGVB6" () As Collection
#End If
 
Private Sub Form_Initialize()
    '
    Dim i&, v: On Error Resume Next
    ChDir App.Path 'Заходим в папку проекта
    #If References Then 'Пре-компиляция
    #Else 'Здесь предусмотренна загрузка классов из нативной DLL
        For Each v In UGCollection: i = i + 1
            CallByName Me, Choose(i, "ugf", "ugh", "ugo", "ugtmr", "ugt"), VbSet, v
        Next
    #End If
    ugo.UG_InitCommonControls 'Иннициализация windows-контроллов
    ugo.FrameRePaint Controls 'Для корректного отображения (с манифестом)
    Lang 'Переход к свойствам
    ugtmr.StartTimer Me, "CheckLang", 100 'мониторинг Eng-Rus
End Sub
 
Sub Lang() 'Русский-английский интерфейс
    'Вторую часть текста, я *тупо* перевел через яндекс-перевод
    'это всё для наглядности
    'а вообще можно было загрузить INI-файл, или ресурс
    Dim f&, s$, j$(), u&, v
    Option1(0) = 1
    If ugf.KeyboardLayout = "Русский" Then
        Option1(1) = 1
        s = s & "Command1, Caption, Начать хук 1" & vbCrLf
        s = s & "Command2, Caption, Начать хук 2" & vbCrLf
        s = s & "Command3, Caption, Снять все хуки" & vbCrLf
        s = s & "Text1, Text , Сдвинь меня" & vbCrLf
        s = s & "Text2, Text, Сдвинь меня" & vbCrLf
        s = s & " Frame1, Caption, Образец" & vbCrLf
        s = s & " Frame2, Caption, Смена раскладки" & vbCrLf
        s = s & " Option1, 0, Caption, Английский (США)" & vbCrLf
        s = s & " Option1, 1, Caption, Русский" & vbCrLf
        s = s & " Frame3, Caption, Работа с файловой системой" & vbCrLf
        s = s & "Command4, 0,Caption, Обзор" & vbCrLf
        s = s & "Command4, 1,Caption, Открыть" & vbCrLf
    Else
        s = s & " Command1, Caption, Start hook 1" & vbCrLf
        s = s & "Command2 ,Caption, Start hook 2" & vbCrLf
        s = s & "Command3, Caption, Remove all hooks" & vbCrLf
        s = s & "Text1, Text , Shift me" & vbCrLf
        s = s & "Text2, Text, Shift me" & vbCrLf
        s = s & " Frame1, Caption, Sample" & vbCrLf
        s = s & " Frame2, Caption, Change keyboard layout" & vbCrLf
        s = s & " Option1, 0, Caption, English (USA)" & vbCrLf
        s = s & " Option1, 1, Caption, Russian" & vbCrLf
        s = s & " Frame3, Caption, File system" & vbCrLf
        s = s & "Command4, 0,Caption, Review" & vbCrLf
        s = s & "Command4, 1,Caption, Open" & vbCrLf
    End If
    Call ugo.LetProp(Me, s) 'добавление этих свойств контролам нашей формы
End Sub
 
Private Sub Option1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    'Программная смена расскладки
    If Option1(1).Value Then
        ugf.NewKeyboardLayout ("00000419") 'Русский
    Else
        ugf.NewKeyboardLayout ("00000409") 'Английский
    End If
End Sub
 
Private Sub Command4_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    'Примеры вызова окна папок, файлов и подсказок по правой кнопке мышки
    Const s = "Если я тебе не нравлюсь," & vbCrLf & _
    "Застрелись, я не исправлюсь"
    On Error Resume Next
    Select Case Index
    Case 0
        If Button = 1 Then
            Text3(Index) = ugo.ShowFolders(Me, "Выбери любую папку", Text3(Index))
        Else
            ugt.ShowTT Command4(Index), Command4(Index).Caption, "Многострочная подсказка"
        End If
    Case 1
        If Button = 1 Then
            Text3(Index) = ugo.OpenSave(Me)(0)
        Else
            ugt.ShowTT Command4(1), Command4(1).Caption, s
        End If
    End Select
End Sub
 
Sub CheckLang()
    'процедура, вызываемая таймером
    Static oldLang$, s$
    s = ugf.KeyboardLayout: If oldLang$ = "" Then oldLang$ = s
    If oldLang <> ugf.KeyboardLayout Then Lang
    oldLang = s
End Sub
 
Public Function TxBtnDown(ParamArray arg())
    'процедура, вызываемая хуком, с передачей параметров
    '*! остановки этого кода недопустимы
    arg(1) = WM_NCLBUTTONDOWN
    arg(2) = HTCAPTION
    TxBtnDown = 1 'Любое число ( >0 ) для операции возврата
End Function
 
Private Sub Command1_Click()
    'Здесь пример создания хука, на Text1, тоесть какое сообщение ловится, _
    какому объекту передаётся, и какой процедуре
    '>*! Примечание, эти процедуры должны быть обявленны Public ..
    ugh.AddHook Text1.hWnd, WM_LBUTTONDOWN, Me, "TxBtnDown"
End Sub
Private Sub Command2_Click()
    ugh.AddHook Text2.hWnd, WM_LBUTTONDOWN, Me, "TxBtnDown"
End Sub
 
Private Sub Command3_Click()
    ugh.UnHookPtr
End Sub

Новые блоги и статьи Все статьи Все блоги /
Локальный http сервер Argus19 17.10.2026 Локальный http сервер На работе, на двух локальных компьютерах круглосуточно работают программы опроса приборов с записью в книги Excel,которые раз в сутки записываются на сервер компании. Т. к. . . .	Копировать Windows на новый диск на UEFI damix 17.10.2026 https:/ / uriesk. wordpress. com/ 2016/ 11/ 01/ move-window-10-to-ssd-on-a-uefi-dualboot-system-with-basic-linux-tools/ TL DR Вставляем диск, а старый подключаем через переходник, грузимся с лайва. . .	ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .
Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .	Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .

@Антихакер32 1201 / 473 / 46 Регистрация: 06.01.2014 Сообщений: 1,797 Записей в блоге: 19

	Мои примеры 21.07.2014, 14:44. Показов 5224. Ответов 25 Метки нет (Все метки) Здесь я буду, время от времени размещать свои решения если у кого будут пожелания, просьба высказываться конструктивно соблюдать правила, и не переходить на личности Итак: "регистрация компонента" Зарегить компонент можно несколькими способами один из них хочу предоставить здесь Добавлено через 4 минуты Добавлю в той библиотеке Dialogs, существует еще несколько классов но это можно узнать если подключить компонент через References 0