Готовые решения и полезные коды на Visual Basic 6.0 - VB - Страница 10

@Catstail · 08.12.2016, 15:38

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

А вот мой вариант вычисления определителя и решения системы уравнений методом Крамера:

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
200
201
202
203
204
Private Sub CommandButton1_Click()
      Clear_All
End Sub
 
Private Sub CommandButton2_Click()
      Calc
End Sub
 
'::: Все стереть
 
Sub Clear_All()
 
    Range("C5:L14").Select
    Selection.ClearContents
    
    Range("N5:N14").Select
    Selection.ClearContents
     
    Range("P5:P14").Select
    Selection.ClearContents
     
    Range("C16:C28").Select
    Selection.ClearContents
     
    Range("C5").Select
 
End Sub
 
'::: Решить систему
 
Sub Calc()
 
Dim A() As Double
Dim Y() As Double
Dim R() As Double
Dim flg As Boolean
 
    n% = Range("A3")
    
    '::: Выделяем память
    
    ReDim A(1 To n%, 1 To n%) As Double
    ReDim Y(1 To n%) As Double
    ReDim R(1 To n%) As Double
 
    '::: Загружаем
    
    For i% = 1 To n%
        Y(i%) = Cells(4 + i%, 14).Value
        For j% = 1 To n%
            A(i%, j%) = Cells(4 + i%, 2 + j%).Value
        Next j%
    Next i%
 
    '::: Решаем
 
    Range("P5:P14").Select
    Selection.ClearContents
     
    Range("C16:C28").Select
    Selection.ClearContents
 
    Kramer A, Y, R, flg
 
    If flg Then
    
       For i% = 1 To n%
           Cells(i% + 4, 16).Value = R(i%)
       Next i%
        
    Else
    
       Cells(17, 3).Value = "Решений нет"
        
    End If
 
End Sub
 
Sub Kramer(A() As Double, Y() As Double, R() As Double, flgRes As Boolean)
 
Dim T() As Double
    
    ooo% = 16
    
    n% = UBound(Y, 1)
    D_Main# = Det(A)
    
    Cells(ooo%, 3).Value = "Det-0=" & Format$(D_Main, "0.00000E+")
    
    If Abs(D_Main) <= 0.0000000001 Then
       flgRes = False
       Exit Sub
    End If
    
    ReDim T(1 To n%, 1 To n%) As Double
    
    For ii% = 1 To n%
    
        For i% = 1 To n%
            For j% = 1 To n%
                T(i%, j%) = A(i%, j%)
            Next j%
        Next i%
        
        For j% = 1 To n%
            T(j%, ii%) = Y(j%)
        Next j%
        
        Z# = Det(T)
        
        R(ii%) = Z# / D_Main#
        
        ooo% = ooo% + 1
        Cells(ooo%, 3).Value = "Det-" & CStr(ii%) & "=" & Format$(Z#, "0.00000E+")
        
    Next ii%
    
    flgRes = True
    
End Sub
 
Function Det(A() As Double) As Double
     n% = UBound(A, 1)
     If n% = 2 Then
        Det = A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1)
     Else
        S# = 1
        For j% = 1 To n%
            Det = Det + A(1, j%) * Det(Minor(A(), 1, j%)) * S#
            S# = -S#
        Next j%
     End If
End Function
 
Function Minor(A() As Double, m As Integer, k As Integer) As Double()
Dim B() As Double
    nn% = UBound(A, 1)
    ReDim B(1 To nn% - 1, 1 To nn% - 1) As Double
    ii% = 1
    jj% = 1
    For i% = 1 To nn%
        For j% = 1 To nn%
            If i% <> m And j% <> k Then
               B(ii%, jj%) = A(i%, j%)
               jj% = jj% + 1
               If jj% > nn% - 1 Then
                  ii% = ii% + 1
                  jj% = 1
               End If
            End If
        Next j%
     Next i%
     Minor = B
End Function
 
Sub Test()
 
Dim A(1 To 4, 1 To 4) As Double
Dim Y(1 To 4)         As Double
Dim R(1 To 4)         As Double
Dim flg               As Boolean
 
    A(1, 1) = 1
    A(1, 2) = 1
    A(1, 3) = 1
    A(1, 4) = 1
    
    A(2, 1) = 2
    A(2, 2) = 1
    A(2, 3) = 2
    A(2, 4) = 1
    
    A(3, 1) = 0
    A(3, 2) = 1
    A(3, 3) = 3
    A(3, 4) = -2
    
    A(4, 1) = 7
    A(4, 2) = 1
    A(4, 3) = -1
    A(4, 4) = 5
    
    Y(1) = 0
    Y(2) = 2
    Y(3) = 4
    Y(4) = 0
 
 
 
    Kramer A, Y, R, flg
    
    If flg Then
    
       For i% = 1 To 4
           Debug.Print R(i%)
       Next i%
       
    Else
    
       Debug.Print "Решений нет!"
       
    End If
    
End Sub

@Catstail · 08.12.2016, 15:40

А в дополнение - вычисление обратной матрицы (неоптимально, через определители):

@fever brain · 08.12.2016, 16:54

Сетки, шахматы и PictureBox

Всем привет, натолкнулся на интересные ответы по работе с PictureBox
и вдохновился идеей объеденить в одной небольшой программе для демонстрации.
Вдохновители: The trick и Alex77755

Код программы (для модуля пустой формы)

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
Option Explicit
'
'Сетки и шахматы на VB6
'
Const r = 90
Dim WithEvents cb As CommandButton, WithEvents pb As PictureBox
Dim i&, j&, l&, t&, w&, h&, v
 
Private Sub Grid(ByVal sz&)
    '
    'Сетка
    '
    pb.Cls
    pb.DrawMode = vbCopyPen 
    pb.Scale (0, sz)-(sz, 0)
    For j = 0 To sz
        pb.Line (0, j)-(sz, j)
        pb.Line (j, 0)-(j, sz)
    Next
End Sub
 
Private Sub Chess(ByVal sz&)
    '
    'Шахматы
    '
    pb.Cls
    pb.DrawMode = vbInvert
    pb.Scale
    j = sz * 2
    For i = 0 To j
        pb.Line (0, pb.ScaleHeight / sz * i)-Step(pb.ScaleWidth, pb.ScaleHeight / j), vbBlack, BF
        pb.Line (pb.ScaleWidth / sz * i, 0)-Step(pb.ScaleWidth / j, pb.ScaleHeight), vbBlack, BF
    Next
End Sub
 
 
Private Sub cb_Click()
    Debug.Print cb.Name
    Const cc = 3
    Select Case Mid$(cb.Name, 3)
    Case 1: Grid 3
    Case 2: Grid 8
    Case 3: Grid 50
    Case 4: Chess 8 \ 2
    End Select
End Sub
 
Private Sub Form_Load()
    With Controls.Add("vb.PictureBox", "pb")
        a l, r, t, r, w, .Width * 5, h, .Width * 5: .Move l, t, w, h
            .AutoRedraw = 1:   .Visible = 1
    End With
    a l, r, t, t + h, i, 1
    For Each v In Array("Сетка 3x3", "Сетка 8x8", "Сетка 50x50", "Шахматы 8x8")
        With Controls.Add("vb.CommandButton", "cb" & i)
            a w, .Width * 1.2, h, .Height: .Move l, t, w, h: a l, l + w + r, i, i + 1
            .Caption = v: .Visible = 1
        End With
    Next
    ApplyFinalProp "Сетки и шахматы", r, r
End Sub
 
Private Sub ApplyFinalProp(Optional ByVal Caption$, Optional ByVal Left& = -1, Optional ByVal Top& = -1): Dim w&, h&
    For Each v In Me.Controls
        If v.Left + v.Width > w Then w = v.Left + v.Width
        If v.Top + v.Height > h Then h = v.Top + v.Height
    Next
    With Me
        .Width = w + (.Width - .ScaleWidth) + r: .Height = h + (.Height - .ScaleHeight) + r
        If Caption <> "" Then .Caption = Caption
        If Left >= 0 Then .Left = Left
        If Top >= 0 Then .Top = Top
    End With
End Sub
 
Private Sub cb_LostFocus(): LostFocus: End Sub
Private Sub pb_LostFocus(): LostFocus: End Sub
Private Sub EnCtrl(ByVal val&, ParamArray e()): For Each v In e: Controls(v).Enabled = val: Next: End Sub
Private Sub a(ParamArray e()): Dim i&: For i = 1 To UBound(e) Step 2: e(i - 1) = e(i): Next: End Sub
Private Sub Form_Activate(): Set pb = Controls("pb"): pb.SetFocus: End Sub
Private Sub LostFocus(): On Error Resume Next: Set pb = ActiveControl: Set cb = ActiveControl: End Sub

@fever brain · 13.01.2017, 08:41

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

ВНИМАНИЕ - дочитайте!, Ни в коем случае не запускайте эту прогу
ЕСЛИ вы не использовали первую версию, и не в первой версии свои аки

Дело в том что мое новое детище не будет разбираться чья версия, а просто перепишет файл
или не поймет его..... новая версия будет записывать этот файл: ..\Application Data\Accounts\Accounts.dat

Сделайте бэкаб!

Вы уже потираете руки ?
ИТАК
в новой версии использован иной интерфейс ListView !
иной способ хранения инфы (безструктурный >байтовый )
3. Возможность использования паролей
4. Бэкаб !
максимум функционала в простом интерфейсе (разрабатывал для блондинок)
и просто приятное глазу картинка (обратите внимание на кнопочки)

вот часть исходника.. эта инфа некритична в ней нет основных знаний ))

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
Private Sub SaveAccounts()
    Dim i&, j&, s$, ff&
    With ListView1
        For i = 1 To .ListItems.Count
            With .ListItems(i)
                If i > 1 Then s = s & RowDel
                s = s & .Text
                For j = 1 To .ListSubItems.Count
                     s = s & ColDel
                     s = s & .ListSubItems(j).Text
                Next
            End With
        Next
        s = Me.Tag & RowDel & s
        ''
        '
        '
        For i = 1 To Len(s) 'шифруем заданный текст и сохраняем его в засекреченном виде
            j = Asc(Mid$(s, i, 1)) - GenB(i Mod genMax)
            If j < 0 Then j = (j + 512) Mod 256
            Mid$(s, i, 1) = Chr(j)
        Next
        If Dir(FolderAccouns, vbDirectory) = vbNullString Then MkDir FolderAccouns
        On Error Resume Next
        Kill FolderAccouns & FileAc: ff = FreeFile
        Open FolderAccouns & FileAc For Binary As #ff: Put #ff, 1, s: Close #ff
    End With
End Sub

Извините что не выложу весь исходник, думаю понятно почему..
и извините что покалякал фламастером на картинке
если будут вопросы пишите в личку (программеру можно писать здесь )

Запустить можно не извлекая из архива..

@fever brain · 13.01.2017, 09:06

Если будут еще пожелания, возможно в третьей версии зделаю так:
1 Заполняем базу как это было сказанно выше..
2 Начинаются чудеса! любой браузер даже после переустановки
может предложить экспорт из акаунтов )) тоесть из моей программы
Представьте свою забывчивую жену (подругу) у которой памяти <1 kb
естественно вспомнить старый пароль гдето там в InternetExploer будет непреодолимая задача ))
так вот, ей нужно будет знать только свой один единственный пароль
и после чего все браузеры будут ее помнить ... ... круто же ?

Dragokas · 16.01.2017, 00:22 **[ТС]**

Класс математики битовых сдвигов

Содрал где-то у The Trick.
Добавил:

IDE-Safe (не падает при оставе в IDE)
Dword2Long - Преобразование беззнакового int (UINT, DWORD) в знаковое (VB-Long).
Получение HIWORD и LOWORD.

Мож, тоже кому пригодится.
А по битам там:

Shl - Логический сдвиг влево
Sal - Арифметический сдвиг влево
Shr - Логический сдвиг вправо
Sar - Арифметический сдвиг вправо

Dword2Long полезно, например, если нужно допустим сложить 30-й и 31-й биты, используя, скажем, такую запись:

Visual Basic
1
Debug.Print cMath.Dword2Long(2 ^ 30) Or cMath.Dword2Long(2 ^ 31)

Класс

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
'Bitwise math class by The Trick
'Forked by Dragokas
 
Option Explicit
 
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (arr() As Any) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal ptrFc As Long, ByVal P1 As Long, ByVal P2 As Long, ByVal P3 As Long, ByVal P4 As Long) As Long
 
Private Const HEAP_CREATE_ENABLE_EXECUTE = &H40000
Private Const HEAP_NO_SERIALIZE = &H1
 
Dim Code() As Long, hHeap As Long, lpFunc As Long, lpOldPt As Long, lpSA As Long, inIDE As Boolean, isInit As Boolean
 
Private Sub Class_Initialize()
    inIDE = (App.LogMode = 0)
    If Not inIDE Then
        InitSh
    End If
End Sub
 
Private Sub Class_Terminate()
    DeinitSh
End Sub
 
Sub InitSh()  ' Инициализация процедур
    ReDim Code(4)
    hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, (UBound(Code) + 1) * 4, (UBound(Code) + 1) * 4)
    If hHeap = 0 Then MsgBox "Error creating heap", vbCritical: Exit Sub
    lpFunc = HeapAlloc(hHeap, HEAP_NO_SERIALIZE, (UBound(Code) + 1) * 4)
    If lpFunc = 0 Then MsgBox "HeapAlloc return NULL", vbCritical: Exit Sub
    GetMem4 ByVal ArrPtr(Code()), lpSA
    GetMem4 ByVal lpSA + 12, lpOldPt
    GetMem4 lpFunc, ByVal lpSA + 12
    Code(0) = &H53E58955: Code(1) = &H8B08458B: Code(2) = &HD30C4D: Code(3) = &H5DEC895B: Code(4) = &HC3
    isInit = True
End Sub
 
Public Function DeinitSh() As Boolean   ' Деинициализация
    If isInit Then
        GetMem4 lpOldPt, ByVal lpSA + 12
        If lpFunc Then HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpFunc: lpFunc = 0
        If hHeap Then HeapDestroy hHeap: hHeap = 0
        isInit = False
    End If
End Function
 
Public Function Shl(ByVal Operand As Long, ByVal Count As Long) As Long     ' Логический сдвиг влево
    If inIDE Then InitSh
    Code(2) = &HE0D30C4D
    Shl = CallWindowProc(VarPtr(Code(0)), Operand, Count, 0, 0)
    If inIDE Then DeinitSh
End Function
 
Public Function Sal(ByVal Operand As Long, ByVal Count As Long) As Long     ' Арифметический сдвиг влево
    Sal = Shl(Operand, Count)
End Function
 
Public Function Shr(ByVal Operand As Long, ByVal Count As Long) As Long     ' Логический сдвиг вправо
    If inIDE Then InitSh
    Code(2) = &HE8D30C4D
    Shr = CallWindowProc(VarPtr(Code(0)), Operand, Count, 0, 0)
    If inIDE Then DeinitSh
End Function
 
Public Function Sar(ByVal Operand As Long, ByVal Count As Long) As Long     ' Арифметический сдвиг вправо
    If inIDE Then InitSh
    Code(2) = &HF8D30C4D
    Sar = CallWindowProc(VarPtr(Code(0)), Operand, Count, 0, 0)
    If inIDE Then DeinitSh
End Function
 
Public Function Dword2Long(dword As Double) As Long
    If dword > 2147483647 Then
        Dword2Long = dword - 4294967296#
    Else
        Dword2Long = CLng(dword)
    End If
End Function
 
Public Function LOWORD(dwNum As Long) As Long
    GetMem2 dwNum, LOWORD
End Function
 
Public Function HIWORD(dwNum As Long) As Long
    GetMem2 ByVal VarPtr(dwNum) + 2, HIWORD
End Function

Dragokas · 16.01.2017, 00:45 **[ТС]**

Проверка текста на наличие кодировки UTF-8 (без BOM) (альтернатива MLang)

Известно (а может кому и нет), что MLang весьма уныло определяет кодировку файла UTF-8 (если нету BOM).
Проще сказать, что эта задача ему не по зубам.

Этот код вручную ведёт поиск допустимых последовательностей сиволов UTF-8.
И если находит, в конце высчитывает % вероятности = кол-во подтверждённых UTF-8 / общее кол-во символов.

Функция возвращает Percent == -1, если вероятность 5 % (порог срабатывания по умолчанию).
Вы можете всё сами отрегулировать по желанию.

Сами понимаете, что если в файле только 1 UTF-8 символ из 1000, то тут нужно вам самим решать, что вы хотите, большую вероятность нахождения UTF-8 кодировки или меньшую вероятность ложных срабатываний.

В одной из своих програм я ставил порог >= 1%, но в ней перед детектом на UTF-8 я использую предварительный анализ на наличие BOM, а также нескольких кодировок по данным MLang, например, 1200 (UTF-16).

Код с примером чтения текста из файла

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
Option Explicit
 
Private Sub Form_Load()
    Dim ff          As Integer
    Dim cpPercent   As Long
    Dim CodePage    As Long
    Dim aBuf()      As Byte
    Dim sBuf        As String
    
    ff = FreeFile()
    Open "c:\testfile.txt" For Binary Access Read As #ff
        sBuf = String(LOF(ff), 0&)
        Get #ff, , sBuf
    Close #ff
    
    aBuf() = StrConv(sBuf, vbFromUnicode, &H419&)
    
    'cpPercent - % кол-ва последовательностей UTF-8 по отношению к общему числу символов
    CodePage = GetEncoding_UTF8(aBuf, cpPercent)
    
    If (cpPercent = -1 Or cpPercent > 50) Then
        Debug.Print "It's UTF-8."
    End If
    
    'если нужна большая вероятность, что мы распознаем текст, как UTF-8, можем выставить например, >= 1%
    'If (cpPercent = -1 Or cpPercent >= 1) Then
    'но тогда и вероятность ложного срабатывания будет выше
End Sub
 
Function GetEncoding_UTF8(aBytes() As Byte, Optional Percent As Long) As Long
    On Error GoTo ErrorHandler
    
    Dim c As Long, n As Long, NTotal As Long, i As Long, bSuccess As Boolean, BTC As Long 'bytes to check
    
    Do
        '2-bytes seq.: 110x xxxx, 10xx xxxx (0xC0, 0x80)
        '              110...= 0xC0, 10...= 0x80
        '              111...= 0xE0, 11...= 0xC0
        
        '3-bytes seq.: 1110 xxxx, 10xx xxxx, 10xx xxxx (0xE0, 0x80, 0x80)
        '              111... = 0xE0
        '              1111...= 0xF0
        
        '4-bytes seq.: 1111 0xxx, 10xx xxxx, 10xx xxxx, 10xx xxxx (0xF0, 0x80, 0x80, 0x80)
        '              1111...  = 0xF0
        '              1111 1...= 0xF8
        
        BTC = 0
        If ((aBytes(c) Xor &HC0) And &HE0) = 0 Then
            BTC = 1
        ElseIf ((aBytes(c) Xor &HE0) And &HF0) = 0 Then
            BTC = 2
        ElseIf ((aBytes(c) Xor &HF0) And &HF8) = 0 Then
            BTC = 3
        End If
        
        If (BTC > 0) And ((c + BTC) <= UBound(aBytes)) Then
            bSuccess = True
            For i = c + 1 To c + BTC
                If ((aBytes(i) Xor &H80) And &HC0) <> 0 Then bSuccess = False: Exit For
            Next
            If bSuccess Then n = n + 1
        End If
        
        If aBytes(c) <> 13 And aBytes(c) <> 10 Then
            NTotal = NTotal + 1
        End If
        
        c = c + 1 + BTC
        
    Loop While c <= UBound(aBytes)
    
    If NTotal <> 0 Then
        Percent = n * 100& / NTotal ' n - кол-во совпавших последовательностей
    End If
    
    If Percent >= 5 Then Percent = -1: GetEncoding_UTF8 = 65001 'порог срабатывания выставлен на 5%
 
    Exit Function
ErrorHandler:
    Debug.Print Err; "Parser.GetEncoding_UTF8"
End Function

Dragokas · 17.01.2017, 21:25 **[ТС]**

DirW() - замена стандартному VB Dir() с поддержкой юникода и доп. атрибутов.

Прототип: Dir$(Путь с маской или слешэм на конце, опц. Маска разрешённых атрибутов, опц. Возвращать только каталоги )

Утянул оригинал у The Trick. Он когда-то, как я понял, транслировал напрямую с отладчика, унаследуя все багофичи оригинала - VB Dir().
Если есть желание вернуть дефолтовое поведение, оставив как фичу только поддержку юникода, то: замените константу &H417 на &H16 и удалите обработчик ошибок.

У меня же:
Добавлена правильная обработка атрибута:
- только для чтения (vbReadOnly)
Добавлены атрибуты:
- точка повторной обработки (симлинки / соединения) (vbReparse)
- все объекты (vbAll)
- vbFile (только файлы, без папок)

Enum VbFileAttribute "перегружен" своим, в нём удалены все лишние атрибуты, которые все равно не используются в оригинальной Dir(), оставил только значимые.

+ 3 опциональный аргумент (FoldersOnly); если true, фильтрует файлы, оставляя в выводе только каталоги.
Также функция автоматом фильтрует папки-алиасы "." и ".."

Модуль modDirWideChar

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
Option Explicit
 
Private Const MAX_PATH = 260
 
Public Enum VbFileAttributeExtended
    vbAll = -1&
    vbDirectory = 16& ' mean - include folders also
    vbFile = vbAll And Not vbDirectory
    vbSystem = 4&
    vbHidden = 2&
    vbReadOnly = 1
    vbNormal = 0&
    vbReparse = 1024& 'symlinks / junctions (not include hardlink to file; they reflect attributes of the target)
End Enum
#If False Then
    Dim vbAll, vbFile, vbReparse 'case sensitive protection against modification (for non-overloaded enum variables only)
#End If
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    lpszFileName(MAX_PATH-1) As Integer
    lpszAlternate(13) As Integer
End Type
 
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const INVALID_HANDLE_VALUE As Long = -1
 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" (ByVal lpFileName As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
 
 
Public Function DirW( _
    Optional ByVal PathMaskOrFolderWithSlash As String, _
    Optional AllowedAttributes As VbFileAttributeExtended = vbNormal, _
    Optional FoldersOnly As Boolean) As String
    
    On Error GoTo ErrorHandler
    
    'WARNING note:
    'Original VB Dir$ contains bug: ReadOnly attribute incorrectly handled, so it always is in results
    'This sub properly handles 'RO' and also contains one extra flag: FILE_ATTRIBUTE_REPARSE_POINT (vbReparse)
    'Doesn't return "." and ".." folders.
    'Unicode aware
    
    Const MeaningfulBits As Long = &H417&   'D + H + R + S + Reparse
                                            '(to revert to default VB Dir behaviour, replace it by &H16 value)
    
    Dim fd      As WIN32_FIND_DATA
    Dim lpStr   As Long
    Dim lRet    As Long
    Dim Mask    As Long
    
    Static hFind        As Long
    Static lflags       As VbFileAttributeExtended
    Static bFoldersOnly As Boolean
    
    If hFind <> 0& And Len(PathMaskOrFolderWithSlash) = 0& Then
        If FindNextFile(hFind, fd) = 0& Then FindClose hFind: hFind = 0&: Exit Function
    Else
        If hFind Then FindClose hFind: hFind = 0&
        PathMaskOrFolderWithSlash = Trim(PathMaskOrFolderWithSlash)
        lflags = AllowedAttributes 'cache
        bFoldersOnly = FoldersOnly 'cache
        
        Select Case Right$(PathMaskOrFolderWithSlash, 1&)
        Case "", ":", "/"
            PathMaskOrFolderWithSlash = PathMaskOrFolderWithSlash & "*.*"
        End Select
        
        hFind = FindFirstFile(StrPtr(PathMaskOrFolderWithSlash), fd)
        
        If hFind = INVALID_HANDLE_VALUE Then
            If (Err.LastDllError) > 12& Then hFind = 0&: Err.Raise 52&
            Exit Function
        End If
    End If
    
    Do
        If fd.dwFileAttributes = FILE_ATTRIBUTE_NORMAL Then
            Mask = 0& 'found
        Else
            Mask = fd.dwFileAttributes And (Not lflags) And MeaningfulBits
        End If
        If bFoldersOnly Then
            If Not CBool(fd.dwFileAttributes And vbDirectory) Then
                Mask = 1 'continue enum
            End If
        End If
    
        If Mask = 0 Then
            lpStr = VarPtr(fd.lpszFileName(0))
            DirW = String$(lstrlen(lpStr), 0&)
            lstrcpy StrPtr(DirW), lpStr
            If fd.dwFileAttributes And vbDirectory Then
                If DirW <> "." And DirW <> ".." Then Exit Do 'exclude self and relative paths aliases
            Else
                Exit Do
            End If
        End If
    
        If FindNextFile(hFind, fd) = 0 Then FindClose hFind: hFind = 0: Exit Function
    Loop
    
    Exit Function
ErrorHandler:
    Debug.Print Err; Err.Description; "DirW"
End Function

Примеры использования с пояснением:

Собственно, синтаксис стандартный для Dir() + 3-й опциональный аргумент.

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
Option Explicit
 
Private Sub Form_Load()
    Dim sFile$
    
    'Перечислить все файлы и папки (не-рекурсивно)
    sFile = DirW("c:\temp\test\", vbAll)
 
    Do While sFile <> ""
        Debug.Print sFile
        sFile = DirW$()
    Loop
    
    Stop: End
    ' перечислить только файлы (без каталогов)
    sFile = DirW("c:\temp\test\", vbFile)
    ' do ... loop
 
    ' перечислить только каталоги, исключить точки повторной обработки (символьные ссылки и соединения)
    ' это полезно, например, если вы строите рекурсию (защита от зацикливания на симлинках)
    sFile = DirW("c:\temp\test\", Not vbReparse, FoldersOnly:=True)
    ' do ... loop
 
    ' перечислить всё, кроме объектов с атрибутами "каталог", "только для чтения", "точка повторной обработки"
    sFile = DirW("c:\temp\test\", vbHidden Or vbSystem)
End Sub

Dragokas · 17.01.2017, 21:53 **[ТС]**

MkDirW() - замена VB MkDir() с поддержкой юникода и созданием всей структуры подкаталогов, если промежуточные папки отсутствуют
IsFile, IsFolder - проверка, существует ли файл / папка, с поддержкой юникодных путей

Использование простое.
У MkDirW() есть доп. опциональный параметр. Всё должно быть ясно из комментариев.
Все функции поддерживают относительные пути.

Код

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
Option Explicit
 
Private Const MAX_PATH = 260
 
Private Const INVALID_HANDLE_VALUE As Long = -1
 
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryW" (ByVal lpPathName As Long, lpSecurityAttributes As Any) As Long
Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
 
 
Public Function IsFolder(ByVal Path As String) As Boolean
    Dim L As Long
    Path = Trim(Path)
    L = GetFileAttributes(StrPtr(Path))
    IsFolder = CBool(L And vbDirectory) And (L <> INVALID_HANDLE_VALUE)
End Function
 
Public Function IsFile(ByVal Path As String) As Boolean
    Dim L As Long
    Path = Trim(Path)
    L = GetFileAttributes(StrPtr(Path))
    IsFile = Not CBool(L And vbDirectory) And (L <> INVALID_HANDLE_VALUE)
End Function
 
Function MkDirW(ByVal Path As String, Optional ByVal LastComponentIsFile As Boolean = False) As Long
    ' Создает структуру каталогов
    ' LastComponentIsFile - является ли последний компонент указанного пути файлом ?
    ' Возвращаемое значение: true, если успех
    Dim FC As String, lr As Long, pos As Long
    If LastComponentIsFile Then Path = Left(Path, InStrRev(Path, "\") - 1) ' урезаю имя файла
    If InStr(Path, ":") = 0 Then 'относительный путь
        Dim sCurDir$, nChar As Long
        sCurDir = String$(MAX_PATH, 0&)
        nChar = GetCurrentDirectory(MAX_PATH + 1, StrPtr(sCurDir))
        sCurDir = Left$(sCurDir, nChar)
        If Right$(sCurDir, 1) <> "\" Then sCurDir = sCurDir & "\"
        Path = sCurDir & Path
    End If
    Do
        pos = pos + 1
        pos = InStr(pos, Path, "\")
        If pos Then FC = Left(Path, pos - 1) Else FC = Path
        lr = 1
        If Not IsFolder(FC) Then lr = CreateDirectory(StrPtr(FC), ByVal 0&)
    Loop While (pos <> 0) And (lr <> 0)
    MkDirW = lr
End Function

Dragokas · 17.01.2017, 22:31 **[ТС]**

AppPathW(), AppExeNameW() - замена VB App.Path и App.Exename с поддержкой юникодных путей / имени файла.

Собсвенно, многие любят хранить рядом с программой всякие интересные вещи.
Но если юзеръ положит эту программу куда-то в папку, где есть хоть один символ за пределами ASCII, то будет долго кричать "не работает!!!", т.к. вы использовали у себя App.Path, а он с юникодом не работает.

Вообщем, кода под спойлером я написал дофига, но оно того стоит от чего и работает по-человечески на всех ОС (читай, соответствует VB-шному оригиналу).

В дополнение там есть функции GetWindowsDir() - здесь и так понятно, и GetDOSFilename() преобразует путь 8.3 в полный и в обратную сторону.
Пользуйтесь на здоровье

Синтаксис с доп. опциональным параметром-фичей:

'получить путь к исполняемому образу программы:
AppPathW( опц. добавлять к пути имя исполняемого файла? )

'получить имя исполняемого образа программы:
AppExeNameW( опц. дописывать к имени файла его расширение? )

Функции умеют корректно отображать расширение имени образа, если оно отличается от .exe.

Кликните здесь для просмотра всего текста

Модуль

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
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
Option Explicit
 
Const MAX_PATH      As Long = 260&
Const MAX_PATH_W    As Long = 32767&
 
Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion(255) As Byte
    wServicePackMajor As Integer
    wServicePackMinor As Integer
    wSuiteMask As Integer
    wProductType As Byte
    wReserved As Byte
End Type
 
Private Declare Function GetModuleFileName Lib "kernel32.dll" Alias "GetModuleFileNameW" (ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal uSize As Long) As Long
Private Declare Function GetLongPathName Lib "kernel32.dll" Alias "GetLongPathNameW" (ByVal lpszShortPath As Long, ByVal lpszLongPath As Long, ByVal cchBuffer As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameW" (ByVal lpszLongPath As Long, ByVal lpszShortPath As Long, ByVal cchBuffer As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As OSVERSIONINFOEX) As Long
 
Private Const VER_NT_WORKSTATION        As Long = 1&
 
Public Function AppPathW(Optional bGetFullPath As Boolean) As String
    On Error GoTo ErrorHandler
 
    Static ProcPathFull  As String
    Static ProcPathShort As String
    Dim ProcPath As String
    Dim Cnt      As Long
    Dim hProc    As Long
    Dim pos      As Long
    Dim inIDE    As Boolean
    
    'Cache
    If bGetFullPath Then
        If Len(ProcPathFull) <> 0 Then
            AppPathW = ProcPathFull
            Exit Function
        End If
    Else
        If Len(ProcPathShort) <> 0 Then
            AppPathW = ProcPathShort
            Exit Function
        End If
    End If
 
    inIDE = (App.LogMode = 0)
 
    If inIDE Then
        AppPathW = GetDOSFilename(App.Path, bReverse:=True)
        'bGetFullPath does not supported in IDE
        Exit Function
    End If
 
    hProc = GetModuleHandle(0&)
    If hProc < 0 Then hProc = 0
 
    ProcPath = String$(MAX_PATH, vbNullChar)
    Cnt = GetModuleFileName(hProc, StrPtr(ProcPath), Len(ProcPath)) 'hproc can be 0 (mean - current process)
    
    If Cnt = MAX_PATH Then 'Path > MAX_PATH -> realloc
        ProcPath = Space$(MAX_PATH_W)
        Cnt = GetModuleFileName(hProc, StrPtr(ProcPath), Len(ProcPath))
    End If
    
    If Cnt = 0 Then                          'clear path
        ProcPath = App.Path
    Else
        ProcPath = Left$(ProcPath, Cnt)
        If StrComp("\SystemRoot\", Left$(ProcPath, 12), 1) = 0 Then ProcPath = GetWindowsDir() & Mid$(ProcPath, 12)
        If "\??\" = Left$(ProcPath, 4) Then ProcPath = Mid$(ProcPath, 5)
        
        If Not bGetFullPath Then
            ' trim to path
            pos = InStrRev(ProcPath, "\")
            If pos <> 0 Then ProcPath = Left$(ProcPath, pos - 1)
        End If
    End If
    
    ProcPath = GetDOSFilename(ProcPath, bReverse:=True)     '8.3 -> to Full
    
    AppPathW = ProcPath
    
    If bGetFullPath Then
        ProcPathFull = ProcPath
    Else
        ProcPathShort = ProcPath
    End If
    Exit Function
ErrorHandler:
    Debug.Print Err; "Parser.AppPath"; "ProcPath:"; ProcPath
    'If inIDE Then Stop: Resume Next
End Function
 
Public Function AppExeNameW(Optional WithExtension As Boolean) As String
    On Error GoTo ErrorHandler
 
    Static ProcPathShort As String
    Static ProcPathFull  As String
    Dim ProcPath As String
    Dim Cnt      As Long
    Dim hProc    As Long
    Dim pos      As Long
    Dim inIDE    As Boolean
 
    'Cache
    If WithExtension Then
        If Len(ProcPathFull) <> 0 Then
            AppExeNameW = ProcPathFull
            Exit Function
        End If
    Else
        If Len(ProcPathShort) <> 0 Then
            AppExeNameW = ProcPathShort
            Exit Function
        End If
    End If
 
    inIDE = (App.LogMode = 0)
 
    If inIDE Then
        AppExeNameW = App.EXEName & IIf(WithExtension, ".exe", "")
        Exit Function
    End If
 
    hProc = GetModuleHandle(0&)
    If hProc < 0 Then hProc = 0
 
    ProcPath = String$(MAX_PATH, vbNullChar)
    Cnt = GetModuleFileName(hProc, StrPtr(ProcPath), Len(ProcPath)) 'hproc can be 0 (mean - current process)
    
    If Cnt = MAX_PATH Then 'Path > MAX_PATH -> realloc
        ProcPath = Space$(MAX_PATH_W)
        Cnt = GetModuleFileName(hProc, StrPtr(ProcPath), Len(ProcPath))
    End If
    
    If Cnt = 0 Then                          'clear path
        ProcPath = App.EXEName & IIf(WithExtension, ".exe", "")
    Else
        ProcPath = Left$(ProcPath, Cnt)
        
        pos = InStrRev(ProcPath, "\")
        If pos <> 0 Then ProcPath = Mid$(ProcPath, pos + 1)
        
        If Not WithExtension Then
            ProcPath = GetFileName(ProcPath)
        End If
    End If
    
    AppExeNameW = ProcPath
    
    If WithExtension Then
        ProcPathFull = ProcPath
    Else
        ProcPathShort = ProcPath
    End If
    
    Exit Function
ErrorHandler:
    Debug.Print Err; "Parser.AppExeName"; "ProcPath:"; ProcPath
    'If inIDE Then Stop: Resume Next
End Function
 
'if short name is unavailable, it returns source string anyway
Public Function GetDOSFilename$(sFile$, Optional bReverse As Boolean = False)
    'works for folders too btw
    Dim Cnt&, sBuffer$
    If bReverse Then
        sBuffer = Space$(MAX_PATH_W)
        Cnt = GetLongPathName(StrPtr(sFile), StrPtr(sBuffer), Len(sBuffer))
        If Cnt Then
            GetDOSFilename = Left$(sBuffer, Cnt)
        Else
            GetDOSFilename = sFile
        End If
    Else
        sBuffer = Space$(MAX_PATH)
        Cnt = GetShortPathName(StrPtr(sFile), StrPtr(sBuffer), Len(sBuffer))
        If Cnt Then
            GetDOSFilename = Left$(sBuffer, Cnt)
        Else
            GetDOSFilename = sFile
        End If
    End If
End Function
 
Public Function GetWindowsDir() As String
    Static SysRoot As String
    Static IsInit As Boolean
    Dim lr As Long
    Dim osi As OSVERSIONINFOEX
    
    If IsInit Then
        GetWindowsDir = SysRoot
        Exit Function
    End If
    
    IsInit = True
    GetVersionEx osi
    
    If osi.wProductType = VER_NT_WORKSTATION Then
        SysRoot = String$(MAX_PATH, 0&)
        lr = GetWindowsDirectory(StrPtr(SysRoot), MAX_PATH)
        If lr Then
            SysRoot = Left$(SysRoot, lr)
        Else
            SysRoot = Environ$("SystemRoot")
        End If
    Else
        SysRoot = Environ$("SystemRoot") 'avoid path virtualization on Windows Server with Terminal Services
    End If
    GetWindowsDir = SysRoot
End Function
 
' Получить только имя файла (без расширения имени)
Public Function GetFileName(Path As String) As String
    Dim posDot      As Long
    Dim posSl       As Long
    
    posSl = InStrRev(Path, "\")
    If posSl <> 0 Then
        posDot = InStrRev(Path, ".")
        If posDot < posSl Then posDot = 0
    Else
        posDot = InStrRev(Path, ".")
    End If
    If posDot = 0 Then posDot = Len(Path) + 1
    
    GetFileName = Mid$(Path, posSl + 1, posDot - posSl - 1)
End Function

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

Visual Basic
1
2
3
4
5
6
Private Sub Form_Load()
    Debug.Print AppPathW()
    Debug.Print AppPathW(bGetFullPath:=True)
    Debug.Print AppExeNameW()
    Debug.Print AppExeNameW(WithExtension:=True)
End Sub

Dragokas · 17.01.2017, 23:53 **[ТС]**

File System Redirector, или как правильно его отключать / включать

Если вы взаимодействуете с одной из этих папок:

%windir%\system32\catroot
%windir%\system32\catroot2
%windir%\system32\driverstore
%windir%\system32\drivers\etc
%windir%\system32\logfiles
%windir%\system32\spool

на 64-битной ОСи, запуская свою 32-битную программу, иначе говоря работая через подсистему WoW64,
то должны знать, что доступ к этим папкам для файловых операций, проводимых вами, ограничен,
и все ваши попытки будут перенаправлены в папку %SystemRoot%\SysWOW64.

Чтобы всё-таки получить доступ к объектам в этих папках, нужно сперва отключить переадресатор.
Детальнее см. MSDN.

Выключать вы должны его точечно для каждой функции, которой это нужно, после чего сразу же включать,
иначе рискуете обрушить программу, как максимум, ну или спровоцировать undefined behavior. Для некоторых программ такие операции вообще противопоказаны. Если Ваша программа состоит из нескольких потоков, работающих параллельно, пока редиректор отключен, все функции в этих потоках будут вызываться из 64-разрядных библиотек, что вполне гарантированно приведёт к нестандартному поведению или обрушению потока.

За всё время я наломал немало дров, пока нормально не вкурил маны и не переписал корректно обёртку над Wow64RevertWow64FsRedirection / Wow64DisableWow64FsRedirection.
Дело в том, что, например, если вы подадите в функцию вместо глобальной переменной статическую, то можете не заметить особых проблем. Через месяц ваша программа может сойти с ума (у меня так и было), и вы даже не поймёте в чём причина. Согласно докам, переменная исходно должна быть неинициализирована и в процессе работы неизменна.

Вот корректно составленная обёртка и пример её использования.
Не поленитесь почитать комменты в примере использования. Там всё подробно разжёвано.

Кликните здесь для просмотра всего текста

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

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
Option Explicit
 
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
 
Private Sub Form_Load()
    On Error GoTo ErrorHandler
 
    Dim sFilePath As String
    Dim RedirResult As Boolean
 
    'redirector OFF
    
        '2-й аргумент показывает, для какого пути отключаем переадресатор.
        'Если функция определит, что этот путь не нуждается в отключении переадресатора,
        'то она вернёт управление, ничего не сделав
        
        'если 2-й аргумент опустить, переадресатор будет отключен принудительно (если только у вас не x32 битная ОС)
        
        'в 3-й аргумент (если указать) вернётся предыдущее состояние переадресатора
    
    sFilePath = "c:\windows\system32\c_1251.nls"
    
    RedirResult = ToggleWow64FSRedirection(False, sFilePath)
    
    'выполним функцию, для которой потребовалось отключение переадресатора
    
    'полный список путей, на которые влияет File System Redirector смотрите на MSDN:
    'https://msdn.microsoft.com/en-us/library/windows/desktop/aa384187(v=vs.85).aspx
    
    Debug.Print IsFile(sFilePath)
    
    ' если прошлая операция отключения была успешной, включим переадресатор
    If RedirResult Then ToggleWow64FSRedirection True
    
    ' вы должны отключать переадресатор точечно - только для той функции, которой это требуется,
    ' после чего сразу же его включать.
    Exit Sub
ErrorHandler:
    'если что-то пошло не так, не забываем принудительно включить обратно переадресатор
    ToggleWow64FSRedirection True
End Sub
 
Function IsFile(ByVal Path As String) As Boolean
    Dim L As Long
    Path = Trim(Path)
    L = GetFileAttributes(StrPtr(Path))
    IsFile = Not CBool(L And vbDirectory) And (L <> -1)
End Function

Модуль modRedirector:

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
Option Explicit
 
Const MAX_PATH      As Long = 260&
 
Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion(255) As Byte
    wServicePackMajor As Integer
    wServicePackMinor As Integer
    wSuiteMask As Integer
    wProductType As Byte
    wReserved As Byte
End Type
 
Private Declare Sub GetNativeSystemInfo Lib "kernel32.dll" (ByVal lpSystemInfo As Long)
Private Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal uSize As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As OSVERSIONINFOEX) As Long
Private Declare Function Wow64DisableWow64FsRedirection Lib "kernel32.dll" (OldValue As Long) As Long
Private Declare Function Wow64RevertWow64FsRedirection Lib "kernel32.dll" (ByVal OldValue As Long) As Long
 
Private Const VER_NT_WORKSTATION        As Long = 1&
 
Private lWow64Old As Long ' IMPORTANT !!! Do not touch!
 
Public Function ToggleWow64FSRedirection(bEnable As Boolean, Optional PathNecessity As String, Optional OldStatus As Boolean) As Boolean
    'Static lWow64Old        As Long    'Warning: do not use initialized variables for this API !
                                        'Static variables are not allowed !
                                        'lWow64Old is now declared globally
    'True - enable redirector
    'False - disable redirector
 
    'OldStatus: current state of redirection
    'True - redirector was enabled
    'False - redirector was disabled
 
    'Return value is:
    'true if success: specified state has been set.
    'false on failure, or specified state has already set.
 
    Static IsNotRedirected  As Boolean
    Static IsInit           As Boolean
    Static bIsWin64         As Boolean
    Static sWinDir          As String
    Dim lr                  As Long
 
    OldStatus = Not IsNotRedirected
 
    If Not IsInit Then
        IsInit = True
        bIsWin64 = IsWin64()
        sWinDir = GetWindowsDir()
    End If
 
    If Not bIsWin64 Then Exit Function
 
    If Len(PathNecessity) <> 0 Then
        If StrComp(Left$(PathNecessity, Len(sWinDir)), sWinDir, vbTextCompare) <> 0 Then Exit Function
    End If
 
    If bEnable Then
        If IsNotRedirected Then
            lr = Wow64RevertWow64FsRedirection(lWow64Old)
            ToggleWow64FSRedirection = (lr <> 0)
            IsNotRedirected = False
        End If
    Else
        If Not IsNotRedirected Then
            lr = Wow64DisableWow64FsRedirection(lWow64Old)
            ToggleWow64FSRedirection = (lr <> 0)
            IsNotRedirected = True
        End If
    End If
End Function
 
Public Function GetWindowsDir() As String
    Static SysRoot As String
    Static IsInit As Boolean
    Dim lr As Long
    Dim osi As OSVERSIONINFOEX
    
    If IsInit Then
        GetWindowsDir = SysRoot
        Exit Function
    End If
    
    IsInit = True
    GetVersionEx osi
    
    If osi.wProductType = VER_NT_WORKSTATION Then
        SysRoot = String$(MAX_PATH, 0&)
        lr = GetWindowsDirectory(StrPtr(SysRoot), MAX_PATH)
        If lr Then
            SysRoot = Left$(SysRoot, lr)
        Else
            SysRoot = Environ$("SystemRoot")
        End If
    Else
        SysRoot = Environ$("SystemRoot") 'avoid path virtualization on Windows Server with Terminal Services
    End If
    GetWindowsDir = SysRoot
End Function
 
Public Function IsWin64() As Boolean
    Const PROCESSOR_ARCHITECTURE_AMD64 As Long = 9&
    Static IsInit As Boolean
    Static bWin64 As Boolean
    If IsInit Then
        IsWin64 = bWin64
        Exit Function
    End If
    Dim si(35) As Byte
    GetNativeSystemInfo VarPtr(si(0))
    If si(0) And PROCESSOR_ARCHITECTURE_AMD64 Then IsWin64 = True
    bWin64 = IsWin64
    IsInit = True
End Function

Dragokas · 18.01.2017, 00:08 **[ТС]**

Поиск файла по путям PATH так, как это делает интерпретатор CMD

Многим знакома API функция PathFindOnPath. Но она ведёт поиск не так, как CMD.
CMD кроме переменной окружения PATH, ещё смотрит в переменную PathExt
Если по точному совпадению имени файл найти не удалось, то подбирает расширения перебором из %PathExt%.

Кроме того, файл не обязательно должен быть исполняемым.
Например, CMD-шная утилита WHERE умеет находить по путям PATH любой тип файла.

Именно так работает код, приведённый ниже.
Требование/зависимости: наличие модуля modRedirector (см. выше).

Кликните здесь для просмотра всего текста

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

Visual Basic
1
2
3
4
5
Option Explicit
 
Private Sub Form_Load()
    Debug.Print FindOnPath("cmd")
End Sub

Модуль modFindOnPath

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
Option Explicit
 
Const MAX_PATH As Long = 260&
 
Private Declare Function PathFindOnPath Lib "Shlwapi" Alias "PathFindOnPathW" (ByVal pszFile As Long, ppszOtherDirs As Any) As Boolean
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
 
Function FindOnPath(sAppName As String) As String
    On Error GoTo ErrorHandler:
 
    Static Exts
    Static IsInit As Boolean
    Dim ProcPath$
    Dim sFile As String
    Dim sFolder As String
    Dim pos As Long
    Dim i As Long
    Dim FoundFile As Boolean
    Dim sFileTry As String
    
    If Not IsInit Then
        IsInit = True
        Exts = Split(Environ("PathExt"), ";")
        For i = 0 To UBound(Exts)
            Exts(i) = LCase(Exts(i))
        Next
    End If
    
    If IsFile(sAppName) Then
        FindOnPath = sAppName
        Exit Function
    End If
    
    pos = InStrRev(sAppName, "\")
    
    If pos <> 0 Then
        sFolder = Left$(sAppName, pos - 1)
        sFile = Mid$(sAppName, pos + 1)
        
        For i = 0 To UBound(Exts)
            sFileTry = sFolder & "\" & sFile & Exts(i)
            
            If IsFile(sFileTry) Then
                FindOnPath = sFileTry
                Exit Function
            End If
        Next
    Else
        ToggleWow64FSRedirection False
    
        ProcPath = Space$(MAX_PATH)
        LSet ProcPath = sAppName & vbNullChar
        
        If CBool(PathFindOnPath(StrPtr(ProcPath), 0&)) Then
            FindOnPath = TrimNull(ProcPath)
        Else
            'go through the extensions list
            
            For i = 0 To UBound(Exts)
                sFileTry = sAppName & Exts(i)
            
                ProcPath = Space$(MAX_PATH)
                LSet ProcPath = sFileTry & vbNullChar
            
                If CBool(PathFindOnPath(StrPtr(ProcPath), 0&)) Then
                    FindOnPath = TrimNull(ProcPath)
                    Exit For
                End If
            
            Next
            
        End If
        
        ToggleWow64FSRedirection True
    End If
    
    Exit Function
ErrorHandler:
    Debug.Print Err; "FindOnPath"; "AppName: "; sAppName
    ToggleWow64FSRedirection True
    'If inIDE Then Stop: Resume Next
End Function
 
Public Function TrimNull(s$) As String
    TrimNull = Left$(s, lstrlen(StrPtr(s)))
End Function
 
Function IsFile(ByVal Path As String) As Boolean
    Dim L As Long
    Path = Trim(Path)
    L = GetFileAttributes(StrPtr(Path))
    IsFile = Not CBool(L And vbDirectory) And (L <> -1)
End Function

Dragokas · 18.01.2017, 01:24 **[ТС]**

EnvironW() - замена VB Environ() с поддержкой юникода, нескольких переменных в строке и коррекцией под WOW64

Важное замечание: в отличие от родного Environ(), мой требует подачи на вход переменных окружения, обрамлённых символами %%, например:

Visual Basic
1
2
    Debug.Print EnvironW("%UserName% - %UserDomain%")
    Debug.Print EnvironW("%PROGRAMFILES%\My program")

т.к. родной Environ не поддерживает указание нескольких переменных в одной строке.

Также, EnvironW() позволяет скорректировать и "правильно" (в том смысле, что если бы мы хотели это сделать из-под 64-битного приложения) раскрыть под WOW64 такие переменные, как:

%PROGRAMFILES%
%COMMONPROGRAMFILES%

Получив на 64-битной ОС, соответственно:
C:\Program Files, а не C:\Program Files (x86)
C:\Program Files\Common Files, а не C:\Program Files (x86)\Common Files

Кликните здесь для просмотра всего текста

Модуль modEnviron

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
 
Const MAX_PATH As Long = 260&
 
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As Any) As Long
Private Declare Function ExpandEnvironmentStrings Lib "kernel32.dll" Alias "ExpandEnvironmentStringsW" (ByVal lpSrc As Long, ByVal lpDst As Long, ByVal nSize As Long) As Long
 
Public Function EnvironW(ByVal SrcEnv As String) As String
    Dim lr As Long
    Dim buf As String
    Dim SysDisk As String
    Static PF_64 As String, PF_64_Common As String
    Static IsInit As Boolean
 
    If Len(SrcEnv) = 0 Then Exit Function
 
    If InStr(SrcEnv, "%") = 0 Then
        EnvironW = SrcEnv
    Else
        'redirector correction
        If IsWin64() Then
            If InStr(1, SrcEnv, "%PROGRAMFILES%", 1) <> 0 _
              Or InStr(1, SrcEnv, "%COMMONPROGRAMFILES%", 1) <> 0 Then
                If Not IsInit Then
                    IsInit = True
                    If OSverMajorMinor() >= 6.1 Then     'Win 7 and later
                        PF_64 = EnvironW("%ProgramW6432%") 'recur
                    Else
                        SysDisk = EnvironW("%SystemDrive%")
                        PF_64 = SysDisk & "\Program Files" 'Older systems are not supported %ProgramW6432%
                    End If
                    PF_64_Common = PF_64 & "\Common Files"
                End If
 
                If InStr(1, SrcEnv, "%PROGRAMFILES%", 1) <> 0 Then
                    SrcEnv = Replace$(SrcEnv, "%PROGRAMFILES%", PF_64, 1, 1, 1)
                End If
                If InStr(1, SrcEnv, "%COMMONPROGRAMFILES%", 1) <> 0 Then
                    SrcEnv = Replace$(SrcEnv, "%COMMONPROGRAMFILES%", PF_64_Common, 1, 1, 1)
                End If
            End If
        End If
        buf = String$(MAX_PATH, 0&)
        lr = ExpandEnvironmentStrings(StrPtr(SrcEnv), StrPtr(buf), MAX_PATH + 1)
 
        If lr Then
            EnvironW = Left$(buf, lr - 1)
        Else
            EnvironW = SrcEnv
        End If
 
        If InStr(EnvironW, "%") <> 0 Then 'still not expanded ?
            If OSverMajorMinor() <= 6 Then
                If InStr(1, EnvironW, "%ProgramW6432%", 1) <> 0 Then
                    SysDisk = EnvironW("%SystemDrive%") 'recur
                    EnvironW = Replace$(EnvironW, "%ProgramW6432%", SysDisk & "\Program Files", 1, -1, 1)
                End If
            End If
        End If
    End If
End Function
 
Function OSverMajorMinor() As Single
    Dim inf(68) As Long
    Dim dec As Single
    inf(0) = 276
    GetVersionEx inf(0)
    dec = inf(2)
    If dec <> 0 Then Do: dec = dec / 10: Loop Until dec < 1
    OSverMajorMinor = inf(1) + dec
End Function

Dragokas · 19.01.2017, 00:46 **[ТС]**

AppVersionW - корректное получение версии Вашей программы, запущенной в папке с юникодными символами

Кому-то юникод может и нафиг не нужен, но вот не задача,
Вам вдруг захотелось написать в окне "О программе" версию вашей программы. Первая мысль:

App.Major
App.Minor
App.Revision

И тут так совпало, что юзеръ скинул вашу программу в папку, где есть хоть один символ
за пределами ASCII в пути. Он будет долго кричать - "не работает !!!",
потому что программа выбросит Runtime Error. И по правде говоря, здесь Вас обработчик
ошибок тоже особо не спасёт, ведь весь код после App.Major будет пропущен
(если конечно вы заранее не знали об этом баге) (On Error Resume Next не беру в рассчёт).

Готовые решения и полезные коды на Visual Basic 6.0

Итак, код ниже извлекает версию, используя юникодные Win API вызовы:

Кликните здесь для просмотра всего текста

Вызов:

Visual Basic
1
2
3
4
Private Sub Form_Load()
    MsgBox AppVersionW(AppPathW(True))
    'MsgBox AppVersionW(App.Path & "\" & App.EXEName & ".exe")
End Sub

Модуль AppVersion:

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
 
Private Type VS_FIXEDFILEINFO
    dwSignature As Long
    dwStrucVersionl As Integer
    dwStrucVersionh As Integer
    dwFileVersionMSl As Integer
    dwFileVersionMSh As Integer
    dwFileVersionLSl As Integer
    dwFileVersionLSh As Integer
    dwProductVersionMSl As Integer
    dwProductVersionMSh As Integer
    dwProductVersionLSl As Integer
    dwProductVersionLSh As Integer
    dwFileFlagsMask As Long
    dwFileFlags As Long
    dwFileOS As Long
    dwFileType As Long
    dwFileSubtype As Long
    dwFileDateMS As Long
    dwFileDateLS As Long
End Type
 
Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoW" (ByVal lptstrFilename As Long, ByVal dwHandle As Long, ByVal dwLen As Long, lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeW" (ByVal lptstrFilename As Long, lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueW" (pBlock As Any, ByVal lpSubBlock As Long, lplpBuffer As Long, puLen As Long) As Long
Private Declare Function memcpy Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
 
Const FILE_ATTRIBUTE_DIRECTORY  As Long = &H10&
Const INVALID_HANDLE_VALUE      As Long = &HFFFFFFFF
 
Public Function AppVersionW(sImagePath As String) As String
    On Error GoTo ErrorHandler:
    Dim hData&, lDataLen&, uBuf() As Byte, uCodePage(0 To 3) As Byte
    Dim sCodePage$, sCompanyName$, uVFFI As VS_FIXEDFILEINFO, sVersion$
    
    If Not FileExists(sImagePath) Then Exit Function
    
    lDataLen = GetFileVersionInfoSize(StrPtr(sImagePath), ByVal 0&)
    If lDataLen = 0 Then Exit Function
    
    ReDim uBuf(0 To lDataLen - 1)
    If 0 <> GetFileVersionInfo(StrPtr(sImagePath), 0&, lDataLen, uBuf(0)) Then
    
        If 0 <> VerQueryValue(uBuf(0), StrPtr("\"), hData, lDataLen) Then
        
            If hData <> 0 Then
        
                memcpy uVFFI, ByVal hData, Len(uVFFI)
    
                With uVFFI
                    sVersion = .dwFileVersionMSh & "." & _
                        .dwFileVersionMSl & "." & _
                        .dwFileVersionLSh & "." & _
                        .dwFileVersionLSl
                End With
            End If
        End If
    End If
    AppVersionW = sVersion
    Exit Function
ErrorHandler:
    Debug.Print Err; "AppVersionW"; sImagePath
End Function
 
Public Function FileExists(ByVal sFile$) As Boolean
    Dim ret As Long
    ret = GetFileAttributes(StrPtr(sFile))
    If ret <> INVALID_HANDLE_VALUE And (0 = (ret And FILE_ATTRIBUTE_DIRECTORY)) Then FileExists = True
End Function

Зависимость / требования: наличие модуля с AppPathW().

Dragokas · 19.01.2017, 01:07 **[ТС]**

Класс получения информации об ОС

Обновлённая версия этого класса.

Добавлены свойства:

OS SuiteMask
OS ProductType
OEM CodepageOEM (identifier)
OEM CodepageOEM (path to .nls)
ANSI CodepageANSI (identifier)
ANSI CodepageANSI (path to .nls)

В режиме IDE возвращается правильная версия системы (Major / Minor / Build) вне зависимости, подключен манифест или нет.
Используется запрос к WMI. Это нужно для нормальной отладки программ под IDE.

В релизе подсистема WMI не ипользуется, поэтому Вам все равно обязательно нужно подключать манифест. См. детали по ссылке выше.

Перед использованием класса, замените все обработчики ошибок AppendErrorLogFormat на свои или закомментируйте автозаменой.

24.03.17 файл перезалит. Убрана критическая ошибка, могла привести к падению программы.

Актуальную версию всегда можно найти здесь.

Dragokas · 19.01.2017, 01:34 **[ТС]**

[CMD] Авто-сборщик ресурса из нескольких файлов

Если вы часто обновляете файлы, которые должны лежать в ресурсах у программы,
то конечно же будет лень постоянно переподключать их через GUI.

Это обновлённая версия батника (запчасть от Авто-компилятора).

Как пользоваться?
Скинуть батник в папку с проектом и запустить. Всё.
Но, сперва нужно всё настроить.

Как настроить?

При первом использовании, Вы должны вручную в IDE зайти в Add-Ins, подключить Resource Editor.
Зайти в Tools -> Resource Editor -> Подключить любой файл к проекту и сохранить ресурс под именем RESOURCE.res в корневой папке проекта.

Затем отредактировать батник:
У меня в примере там такие строки:

set Res[1]=1 #24 manifest.txt
set Res[2]=101 CUSTOM TasksWhite.csv
set Res[3]=102 CUSTOM MSCOMCTL.OCX.bak
set Res[4]=103 CUSTOM readme - History.txt
set Res[5]=201 CUSTOM _Lang_EN.lng
set Res[6]=202 CUSTOM _Lang_RU.lng

Это пример. Удалите их все и создайте свои так, как вам нужно.
set Res[1] - это служебный номер (должны идти по порядку).
дальше после = номер ресурса, тип ресурса, имя файла, лежащего рядом с программой, который нужно добавить в ресурс.

В примере выше у меня автоматом подключается манифест.
Всего ресурсов не больше 10. Если нужно больше, поправьте дважды такую строку:

Windows Batch file
1
For /L %%C in (1 1 10) do (

Сохраните, всё готово.

Замечание: Код несовместим с портативными версиями VB6. Если нужна портативность, замените эту часть:

"%PF%\Microsoft Visual Studio\VB98\Wizards\rc.exe"

на путь к rc.exe (допускается относительный путь)

Код батника _1_Update_Resource.cmd

Windows Batch file
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
@echo off
SetLocal EnableExtensions EnableDelayedExpansion
 
:: help info on [url]http://www.vbaccelerator.com/home/VB/Code/Libraries/Resources/Using_RC_EXE/article.asp[/url]
 
echo.
echo :: Creating resource file
echo.
 
Call :GetOSBitness OSBitness
if "%OSBitness%"=="x32" (set "PF=%ProgramFiles%") else (set "PF=%ProgramFiles(x86)%")
cd /d "%~dp0"
 
set Res[1]=1 #24 manifest.txt
set Res[2]=101 CUSTOM TasksWhite.csv
set Res[3]=102 CUSTOM MSCOMCTL.OCX.bak
set Res[4]=103 CUSTOM readme - History.txt
set Res[5]=201 CUSTOM _Lang_EN.lng
set Res[6]=202 CUSTOM _Lang_RU.lng
 
2>NUL del /f /a 1.RC
 
For /L %%C in (1 1 10) do (
  if defined Res[%%C] (
    for /f "tokens=1-2*" %%a in ("!Res[%%C]!") do (
      set "ID=%%a"
      set "type=%%b"
      set "file=%%c"
      >NUL copy /y "!file!" "!file!.tmp" || (
        echo Error occured during creation resource from: "!file!.tmp"
        pause
      )
      echo !ID! !type! LOADONCALL DISCARDABLE "!file!.tmp">> 1.RC
    )
  )
)
 
2>nul del /f /a RESOURCE.res
 
"%PF%\Microsoft Visual Studio\VB98\Wizards\rc.exe" /r /v /fo RESOURCE.res 1.RC && (
    echo.& echo -------   SUCCESS
) || (
    echo Error occured during creation resource from: 1.RC
    pause
)
 
:: Clear
For /L %%C in (1 1 10) do (
  if defined Res[%%C] (
    for /f "tokens=1-2*" %%a in ("!Res[%%C]!") do (
      >NUL del "%%c.tmp"
    )
  )
)
2>NUL del /f /a 1.RC
 
exit /b
 
:GetOSBitness
  set "xOS=x64"& If "%PROCESSOR_ARCHITECTURE%"=="x86" If Not Defined PROCESSOR_ARCHITEW6432 set "xOS=x32"
  set "%~1=%xOS%"
Exit /B

Dragokas · 19.01.2017, 03:04 **[ТС]**

Разблокировка прав на ключи реестра

Этот модуль позволяет снять любые уровни запрета на доступ к ключам реестра (за исключением активной блокировки другим процессом или драйвером и специфическими маскировками, вроде Null).

Сфера применения:
Может использоваться для получения доступа к разделам, защищенных правами LOCAL SYSTEM.
Также позволяет восстановить права для разделов служб (например, при устранении последствий заражения ZeroAcess/Sirefef).

Механизм

Сброс происходит рекурсивно для всех подразделов.
Наследование прав отключается для всех веток, задействованных в фиксе. Новые дочерние подразделы наследуют права родителя как обычно.
Набор применяемых прав зависит от версии ОС, имени улья и полному пути к разделу и в целом выглядит так:

SID | Rights | Inheritance | OS / Path

1. Local System:F (OI)(CI)
2. Administrators:F (OI)(CI)
3. Service alias :F (OI)(CI) (optional) - только для подразделов в HKLM\SYSTEM\CurrentControlSet\services\
4. Trusted Installer:F (OI)(CI) (optional) (Vista+)
5. AppX:R - Все пакеты приложений (OI)(CI) (optional) (Win 8.0+)

Только для HKCU:
6. Users:F (OI)(CI)
7. Restricted:R (OI)(CI)

Только для не HKCU:
6. Creator:F (CI)
7. Users:R (OI)(CI)
8. PowerUsers:R (OI)(CI) (XP only)

Описание меток:
OI - применяется для этого раздела.
CI - применяется для подразделов.
F - полные права
R - права только на чтение (запрос значения, перечисление подразделов, уведомление, чтение разрешений).

Применение фикса не рекомендуется к очень большому количеству разделов (как например, корню (улью)). Это может существенно увеличить размер реестра и понизить производительность, т.к. отключается наследование. Для подобных операций лучше использовать другие программы, вроде SubInAcl, SetAcl, Windows Repair-all-in-one.

Всегда будьте предельно осторожны при работе с реестром. Делайте резервным копии!!! (например, через ERUNT)
Сброс привилегий некоторых ключей может привести к отказу в работе системы!!! Автор не отвечает за кривые руки пользователя.

Совместимость:
64-битные ключи поддерживаются.
Win XP-10.

Актуальная версия всегда здесь.

Dragokas · 22.01.2017, 23:49 **[ТС]**

[CMD] Поиск не-заэкранированных операторов STOP в исходном коде

Иногда бывает, что в релизную сборку случайно проскакивает STOP, который забыли удалить/заэкранировать.

К тому же, я например, часто использую оператор Stop внутри обработчика ошибок:

Visual Basic
1
2
3
ErrorHandler:
    ErrorMsg ..........
    If inIDE Then Stop: Resume Next

В таком ключе, в исходнике нереально найти утерянный Stop через Ctrl + F.

Этот батник нужно положить в папку с проектом и запустить.
Он сам просканирует файлы *.bas *.frm *.cls и если найдёт ошибку, выдаст:
строку с оператором Stop, номер строки, и имя модуля.

По-умолчанию игнорируется выражение "if inIDE Then Stop".
Если нужно добавить новые исключения, посмотрите, как это сделано рядом с ключевой фразой call :SkipKeyWords.

@fever brain · 17.02.2017, 07:16

Еще раз здравствуйте, выкладываю очередную версию 2-1
радикально ничего не поменялось способы хранения те-же
добавилась кнопка в области редактирования с рисунком магиии
Так-же исправленн глюк при старте отображения окна

Не по теме:

Скучно без коментариев программера ))

@fever brain · 17.02.2017, 07:39

Пароль генерируется поверх старого, тоесть если раньше было 12345, то по нажатии этой кнопки будет

qwexc146d
12345

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

Если программа будет жаловаться на то что не может найти модуль
то поместите эту длл в папку с программой, в версии 2-0 я уже выкладывал её...

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL3_image 8Observer8 10.02.2026 Содержание блога Библиотека SDL3_image содержит инструменты для расширенной работы с изображениями. Пошагово создадим проект для загрузки изображения формата PNG с альфа-каналом (с прозрачным. . .	Установка Qt-версии Lazarus IDE в Debian Trixie Xfce volvo 10.02.2026 В общем, достали меня глюки IDE Лазаруса, собранной с использованием набора виджетов Gtk2 (конкретно: если набирать текст в редакторе и вызвать подсказку через Ctrl+Space, то после закрытия окошка. . .
SDL3 для Web (WebAssembly): Работа со звуком через SDL3_mixer 8Observer8 08.02.2026 Содержание блога Пошагово создадим проект для загрузки звукового файла и воспроизведения звука с помощью библиотеки SDL3_mixer. Звук будет воспроизводиться по клику мышки по холсту на Desktop и по. . .	SDL3 для Web (WebAssembly): Основы отладки веб-приложений на SDL3 по USB и Wi-Fi, запущенных в браузере мобильных устройств 8Observer8 07.02.2026 Содержание блога Браузер Chrome имеет средства для отладки мобильных веб-приложений по USB. В этой пошаговой инструкции ограничимся работой с консолью. Вывод в консоль - это часть процесса. . .	SDL3 для Web (WebAssembly): Обработчик клика мыши в браузере ПК и касания экрана в браузере на мобильном устройстве 8Observer8 02.02.2026 Содержание блога Для начала пошагово создадим рабочий пример для подготовки к экспериментам в браузере ПК и в браузере мобильного устройства. Потом напишем обработчик клика мыши и обработчик. . .	Философия технологии iceja 01.02.2026 На мой взгляд у человека в технических проектах остается роль генерального директора. Все остальное нейронки делают уже лучше человека. Они не могут нести предпринимательские риски, не могут. . .

@fever brain oh my god 1456 / 796 / 161 Регистрация: 05.01.2016 Сообщений: 2,307 Записей в блоге: 8
	13.01.2017, 09:06
	Если будут еще пожелания, возможно в третьей версии зделаю так: 1 Заполняем базу как это было сказанно выше.. 2 Начинаются чудеса! любой браузер даже после переустановки может предложить экспорт из акаунтов )) тоесть из моей программы Представьте свою забывчивую жену (подругу) у которой памяти <1 kb естественно вспомнить старый пароль гдето там в InternetExploer будет непреодолимая задача )) так вот, ей нужно будет знать только свой один единственный пароль и после чего все браузеры будут ее помнить ... ... круто же ? 1