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

SoftIce · 24.09.2013, 07:25

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

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

Обновленный API Viewer

Не по теме:

У некоторых и необновленного нет :)

Выкладываю два "старых".

@JoraVoenyjHaker · 17.10.2013, 07:53

Перекодирование текста стандартными средствами Windows
Сохранение и загрузка списка
Запись байт в файл (Возврат: Следующая позиция записи (при успешном выполнении)
Чтение байт из файла (Возврат: Массив байт)

Вот мой готовый модуль для удовлетворения почти всех потребностей в работе с файлами
работает в обычном модуле .Bas
но вы можете установить в своём классе, или объекте

Код обсуждается в теме: Файловые операции

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
Option Explicit
DefLng F, H-I, L, N, U: DefDbl D, M: DefStr J, S: DefBool B: DefObj O: DefVar V
'
'                   Модуль для работы с файлами и сохранением списков
'                   ©JoraVoenyjHaker
'
'--------------------------[Константы]
Private Const MaxSpace = 256
Public Enum F_ReCod
    [Без изменений] = 0
    [Windows To DOS] = 1
    [DOS To Windows] = 2
    [Binary To Unicode] = 4
    [Unicode To Binary] = 8
    [Без нулей справа] = 16
    [Без нулей слева] = 32
End Enum
'--------------------------[Переменные модуля]
Dim FxSpace As String * MaxSpace, Byt() As Byte
Dim f, n, n1, Dln, AnyString$, i, Dln1&
'--------------------------[Api Функции]
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
 
Public Function LoadList(Path$) As String()
    'Загрузка списка
    Dim f, f1, ul, n, n1, i, j(), text$
    text = ReadBytes(Path, [Binary To Unicode])
 
    For f = 1 To 3
        n = n * 256 + Asc(Mid$(text, f, 1))
    Next
    ul = Fix(n) / 3: n = n Mod 3
    ReDim j(ul)
    On Error GoTo 10
 
    For f = 4 To ul * (n + 1) + 4 Step n + 1
        n1 = 0
 
        For f1 = f To f + n
            n1 = n1 * 256 + Asc(Mid$(text, f1, 1))
        Next
        j(i) = n1: i = i + 1
    Next
 
    For f1 = 0 To ul
        n = j(f1)
        j(f1) = Mid$(text, f, n)
        f = f + n
    Next
10
    LoadList = j
End Function
 
Public Sub SaveList(Path$, List$())
    'Сохранение списка
    Dim f, f1, ul, n, j()
    ul = UBound(List)
    '-------------
    ReDim Preserve j(ul + 1)
 
    For f = 1 To ul + 1
        n = Len(List(f - 1))
        j(f) = Space(3)
 
        For f1 = 3 To 1 Step -1
            Mid$(j(f), f1, 1) = Chr(n Mod 256)
            n = Fix(n / 256)
        Next
    Next
    '----------------------- Сжать индексы
    For f = 2 To 0 Step -1
 
        For f1 = 1 To ul + 1
            If Mid$(j(f1), 1, 1) <> vbNullChar Then GoTo 10
        Next
 
        For f1 = 1 To ul + 1
            j(f1) = Mid$(j(f1), 2)
        Next
    Next
10
    '------------------ Первая ячейка
    n = ul * 3 + Abs(f)
    j(0) = Space(3)
 
    For f = 3 To 1 Step -1
        Mid$(j(0), f, 1) = Chr(n Mod 256)
        n = Fix(n / 256)
    Next
    Call WriteBytes(Path, Join(j, "") & Join(List, ""), [Unicode To Binary], 1, True)
End Sub
 
Public Function WriteBytes&(Path$, Bytes As Variant, Optional ByVal Flag As F_ReCod, Optional ByVal Start& = 1, Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт (Или текст) // Флаг кодировки // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    On Error GoTo 1
    If Overwrite Then Call Kill(Path)
1
    Open Path For Binary As #1
    Byt = Bytes
    If Start Then Else Start = 1
    Put #1, Start, ReCod(Byt, Flag)
    WriteBytes = Start + UBound(Byt) + 1
    Close #1
End Function
 
Public Function ReadBytes(Path$, Optional ByVal Flag As F_ReCod, Optional ByVal Start&, Optional ByVal Dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Флаг кодировки // Старт // Длина
    'Возврат: Массив байт
    Open Path For Binary As #1
    On Error Resume Next
    If Start Then Else Start = 1
    Dln1 = LOF(1) - Start + 1
    If Dln = 0 Or Dln > Dln1 Then Dln = Dln1
    ReDim Preserve ReadBytes(Dln - 1)
    Get #1, Start, ReadBytes
    ReadBytes = ReCod(ReadBytes, Flag)
    Close #1
End Function
 
Public Function ReCod(Bytes As Variant, Optional ByVal Flag As F_ReCod) As Byte()
    'Перекодирование текста стандартами Windows
    'Bytes: Массив байт (Или текст)
    'Flag: Комбинируемые команды: [DOS to Windows] + [Binary to Unicode] ...
    ReCod = Bytes
 
    While Flag > 0
 
        Select Case Flag
        Case Is >= [Без нулей слева]
            Flag = Flag - [Без нулей слева]
            n = MaxSpace
            f = 1
 
            Do While n > 0
 
                For f = f To UBound(ReCod) + 1 Step n
                    If Mid$(ReCod, f, n) <> Mid$(FxSpace, 1, n) Then Exit For
                Next
                n = n / 2
            Loop
            ReCod = Mid$(ReCod, f)
        Case Is >= [Без нулей справа]
            '-------------------------
            ReCod = StrReverse(ReCod)
            Flag = Flag - [Без нулей справа]
            n = MaxSpace
            f = 1
 
            Do While n > 0
 
                For f = f To UBound(ReCod) + 1 Step n
                    If Mid$(ReCod, f, n) <> Mid$(FxSpace, 1, n) Then Exit For
                Next
                n = n / 2
            Loop
            ReCod = StrReverse(Mid$(ReCod, f))
            '-----------------------------------------------
        Case Is >= [Unicode To Binary]
            Flag = Flag - [Unicode To Binary]
            ReCod = StrConv(ReCod, vbFromUnicode)
        Case Is >= [Binary To Unicode]
            Flag = Flag - [Binary To Unicode]
            ReCod = StrConv(ReCod, vbUnicode)
        Case Is >= [DOS To Windows]
            Flag = Flag - [DOS To Windows]
            AnyString = ReCod
            Call OemToChar(ReCod, AnyString)
            ReCod = AnyString
        Case Is >= [Windows To DOS]
            Flag = Flag - [Windows To DOS]
            AnyString = ReCod
            Call CharToOem(ReCod, AnyString)
            ReCod = AnyString
        End Select
    Wend
End Function

@zink0000 · 17.10.2013, 10:09

Перекодировка текстовых файлов из ANSI в Unicode UTF-8

Программа позволяет конвертировать текстовые файлы в заданном каталоге (со всеми вложенными подкаталогами)
из кодировки ANSI в Unicode UTF-8, копируя файлы в каталог-результат.
win2utf8.zip
Может пригодится кому.

Внимание! При назначении папки для результатов обратите внимание на сообщение "ВСЕ файлы и ВСЕ папки в этом каталоге будут УДАЛЕНЫ!" Не назначайте в качестве каталога-результата каталог с ценной для Вас информацией!

@JoraVoenyjHaker · 19.10.2013, 01:11

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

Да вот ещё что, нормальная работа может быть гарантирована
если установлен VB6

скриншот к StyleCreator

@JoraVoenyjHaker · 24.10.2013, 14:29

Очередное моё решение по транслитерации текста
ниже преведен готовый алгоритм

тема обсуждается в Замена кириллицы на транслит

Модуль Form1:

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
Option Explicit
'
'       Алгоритм быстрой транслитирации
'       работает на Form1 контроле Text1
'       rezj - Текущее значение по умолчанию "РЕЖИМ ENG"
'       © JoraVoenyjHaker
'
Private dicReplace As Object
Private bsi As Object
Private rezj$
 
Private Sub Form_Initialize()
    Text1.Text = " "
    Const r = "/"
    Dim jr$(), je$(), jb$(), f&
    Dim rus$, eng$, bsini$
    rezj = "РЕЖИМ ENG" 'По умолчанию включен "РЕЖИМ ENG"  
    ''rezj = "РЕЖИМ RUS"
    rus = "а/б/в/г/д/е/ё/ж/з/и/й/к/л/м/н/о/п/р/с/т/у/ф/х/ц/ч/ш/щ/ъ/ы/ь/э/ю/я"
    eng = "a/b/v/g/d/e/yo/j/z/i/i`/k/l/m/n/o/p/r/s/t/u/f/h/c/ch/sh/s`/``/y`/`/e`/iu/ia"
    bsini = "yo/i`/ch/sh/``/y`/e`/iu/ia"
    jr = Split(rus, r): je = Split(eng, r): jb = Split(bsini, r)
    Set dicReplace = CreateObject("Scripting.Dictionary") '-----Запись сопоставлений для замены
    With dicReplace
        For f = 0 To UBound(jr): .Add jr(f), je(f): Next
        For f = 0 To UBound(je): .Add je(f), jr(f): Next
    End With
    Set bsi = CreateObject("Scripting.Dictionary")   '-----Запись сопоставлений для удаления
    With bsi
        For f = 0 To UBound(jb): .Add jb(f), "True": Next
    End With
End Sub
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    Static b As Boolean, key$, old$
    On Error Resume Next
    Select Case KeyAscii
    Case 32 'Ничего не происходит
    Case 8
        If rezj = "РЕЖИМ ENG" Then
            If bsi.Item(Mid$(Text1, Text1.SelStart - 1, 2)) Then
                If Not b Then b = True: SendKeys "{BS}", True
            End If
        End If
    Case Else
        'Здесь описание для замены английских
        If rezj = "РЕЖИМ ENG" Then
            key = Mid$(Text1, Text1.SelStart, 1) & Chr(KeyAscii)
            If Len(dicReplace.Item(key)) > 0 Then
                If Not b Then
                    b = True
                    SendKeys "{BS}", True
                    Text1.SelText = dicReplace.Item(key)
                    KeyAscii = 0
                End If
            Else
                key = Chr(KeyAscii)
                If Not b Then
                    b = True
                    Text1.SelText = dicReplace.Item(key)
                    KeyAscii = 0
                End If
            End If
            
        ElseIf rezj = "РЕЖИМ RUS" Then
            key = Chr(KeyAscii)
            old = old & key
            If Len(old) > 1 And Not b And dicReplace.Item(old) <> "" Then
                b = True: SendKeys "{BS}", True
                Text1.SelText = dicReplace.Item(old)
                KeyAscii = 0
            Else
                Text1.SelText = dicReplace.Item(key)
                KeyAscii = 0
            End If
            If Len(old) > 1 Then old = Mid(old, 2)
        End If
    End Select
    b = False
End Sub

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

@KoGG · 24.10.2013, 20:33

Шахматы.

@JoraVoenyjHaker · 24.10.2013, 22:59

Оптимизатор текста (цветной)

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

Скриншот:

@JoraVoenyjHaker · 28.10.2013, 00:37

Относительные пути

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

Тема обсуждается в Относительные пути

Код для модуля формы:

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

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
 
Public Function RelativeName$(AbsName$, Optional RelativeFolder$)
    'Создание относительного пути
    'Арг: Полный путь // Относительная папка [Текущая по умолчанию]
    
    Const r$ = "\", rp$ = "..\"
    Dim MyDir$, ja$(), jr$(), ua&, ur&, f&, Min&, AdUp&, Ign&
    
    MyDir = IIf(RelativeFolder <> vbNullString, RelativeFolder, CurDir$)
    ja = Split(AbsName, r): jr = Split(MyDir, r)
    ua = UBound(ja): ur = UBound(jr)
    Min = IIf(ua < ur, ua, ur) 'верхний индекс для обоих путей
    For f = 0 To Min
        If StrComp(ja(f), jr(f), vbTextCompare) = 0 Then 'Сравнение +игнор. регистра
            ja(f) = vbNullString: Ign = Ign + 1
        ElseIf f = 0 Then 'Если разные драйверы (буква диска)
            RelativeName = AbsName 'Возврат полного пути
            Exit Function
        Else: AdUp = AdUp + 1 'Добавить если папка ещё глубже
        End If
    Next
    RelativeName = Mid$(Join(ja, r), Ign + 1) 'Отрезать путь соответствия
    For f = ur + AdUp To f Step -1 'Добавить трактовку
        RelativeName = rp & RelativeName
    Next
End Function
 
 
Private Sub Form_Load()
    '
    '   Тестирование моей функции RelativeName
    '
    Dim absN$, relF$, result$, o As Object
    Set o = CreateObject("Scripting.FileSystemObject")
    '=================================
1
    absN = "C:\WINDOWS\system32"
    relF = "C:\Program Files\Microsoft Visual Studio\VB98"
    result = RelativeName(absN, relF)
    ChDir (relF) 'Установить текущую
    Debug.Print "Пример 1 ======================================"
    Debug.Print "Абсолютный путь: ", absN & vbCrLf
    Debug.Print "Относительная папка: ", relF & vbCrLf
    Debug.Print "Выходной путь: ", result & vbCrLf
    Debug.Print "Как это видит система:", o.GetAbsolutePathName(result) & vbCrLf
    Debug.Print
2
    absN = "C:\Program Files\Microsoft Visual Studio\VB98"
    relF = "C:\WINDOWS\system32"
    result = RelativeName(absN, relF)
    ChDir (relF)
    Debug.Print "Пример 2 ======================================"
    Debug.Print "Абсолютный путь: ", absN & vbCrLf
    Debug.Print "Относительная папка: ", relF & vbCrLf
    Debug.Print "Выходной путь: ", result & vbCrLf
    Debug.Print "Как это видит система:", o.GetAbsolutePathName(result) & vbCrLf
    Debug.Print
3
    absN = "C:\WINDOWS\system32\SHELL32.dll"
    relF = "C:\Program Files\Microsoft Visual Studio\VB98"
    result = RelativeName(absN, relF)
    ChDir (relF)
    Debug.Print "Пример 3 ======================================"
    Debug.Print "Абсолютный путь: ", absN & vbCrLf
    Debug.Print "Относительная папка: ", relF & vbCrLf
    Debug.Print "Выходной путь: ", result & vbCrLf
    Debug.Print "Как это видит система:", o.GetAbsolutePathName(result) & vbCrLf
    Debug.Print
    Stop 'Остановка /// просмотр окна Immediate
End Sub

Скриншот:

@Антихакер32 · 07.11.2013, 08:22

Сумма прописью

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

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
Option Explicit
'
'   Сумма прописью на русском
'   требуется пустая форма, для демонстрации примера
'   + горячие клавиши правки, Ctrl+C (Копировать).. Ctrl+X (Вырезать).. Ctrl+V (Вставить)..
'   © Антихакер32™ ..2014
'
Const L = 100, T = 100 'Стартовая точка размещения компонентов
Const edn = "ноль один два три четыре пять шесть семь восемь девять"
Const ndc = "одиннадцать двенадцать тринадцать четырнадцать пятнадцать шестнадцать семнадцать восемнадцать девятнадцать"
Const des = "десять двадцать тридцать сорок пятьдесят шестьдесят семьдесят восемьдесят девяносто"
Const sot = "сто двести триста четыреста пятьсот шестьсот семьсот восемьсот девятьсот"
Const tsh = "тысяча тысячи тысяч", mln = "миллион миллиона миллионов", mrd = "миллиард миллиарда миллиардов"
Const valuteRub = "рубль рубля рублей", valuteKop = "копейка копейки копеек"
Dim WithEvents txExp As TextBox, WithEvents txRes As TextBox, WithEvents lab As Label
Dim s$, f&, Fltr$, Kop$
Function SumProp$(ByVal Expression As Double, Optional ByVal val$ = valuteRub, Optional rec&)
    Const p = " ", z = ", ":  Dim s$
    If Expression <> Fix(Expression) Then
        'для вывода инфы копейки округляются до 2-х знаков после запятой
        'например: 0,3 = 30 копеек // 0,03 = три копейки
        Kop = Mid$(Expression, InStr(1, Expression, ",") + 1, 2)
        Kop = Kop & String(2 - Len(Kop), 48)
        Kop = z & SumProp(Kop, valuteKop, rec + 1): Expression = Fix(Expression)
    End If: If Expression >= 2 ^ 31 Then MsgBox "Вы ввели очень большое число", vbInformation: Exit Function
    While Expression > 0
        Select Case Expression
        Case Is >= 10 ^ 9: s = s & SumProp(Fix(Expression \ 10 ^ 9), mrd, rec + 1): Expression = Expression Mod 10 ^ 9
        Case Is >= 10 ^ 6: s = s & SumProp(Expression \ 10 ^ 6, mln, rec + 1): Expression = Expression Mod 10 ^ 6
        Case Is >= 1000: s = s & SumProp(Expression \ 1000, tsh, rec + 1): Expression = Expression Mod 1000
        Case Is >= 100: s = s & Split(sot)(Expression \ 100 - 1) & p: Expression = Expression Mod 100
        Case 10, Is >= 20: s = s & Split(des)(Expression \ 10 - 1) & p: Expression = Expression Mod 10
        Case 11 To 19: s = s & Split(ndc)(Expression - 11) & p: Expression = -Expression
        Case Is < 10: s = s & Split(edn)(Expression) & p: Expression = -Expression
        End Select
    Wend
    If Len(s) Then
        Expression = Abs(Expression)
        Select Case Expression
        Case 1: s = s & Split(val)(0) & IIf(rec And val <> valuteKop, z, "")
        Case 2, 3, 4: s = s & Split(val)(1) & IIf(rec And val <> valuteKop, z, "")
        Case Else: s = s & Split(val)(2) & IIf(rec And val <> valuteKop, z, "")
        End Select: Select Case val
        Case tsh, valuteKop 'исключение, тысяча и копейка в женском роде
            s = Replace(s, "один ", "одна ")
            s = Replace(s, "два ", "две ")
        End Select
    Else: Kop = Trim$(Mid$(Kop, 2))
    End If
    If rec = 0 Then s = s & Kop: Kop = ""
    SumProp = LCase(s): SumProp = UCase(Left$(SumProp, 1)) & Mid$(SumProp, 2)
End Function
Private Sub Form_Resize()
    On Error Resume Next
    With txExp: .Move .Left, .Top, ScaleWidth - L * 2, 0: End With
    With txRes: .Move .Left, .Top, ScaleWidth - L * 2, 0: End With
End Sub
Private Sub txRes_GotFocus(): txRes.SelStart = 0: txRes.SelLength = Len(txRes): End Sub
Private Sub txRes_KeyPress(KeyAscii As Integer)
    With txRes: Select Case KeyAscii
        Case 1: txRes_GotFocus 'Выделить все
        Case 3: Clipboard.Clear: Clipboard.SetText .SelText 'Копировать
        Case 24: If Len(.SelText) Then Clipboard.Clear: Clipboard.SetText .SelText: .Text = "" 'Вырезать
        Case 22: .SelText = Clipboard.GetText 'Вставить
    End Select: End With
End Sub
Private Sub txExp_KeyPress(KeyAscii As Integer)
    Fltr = Choose(Sgn(InStr(1, txExp, ",")) + 1, "[0-9.,бю]", "[0-9]")
    s = Chr(KeyAscii)
    Select Case KeyAscii
    Case Is > 31
        If s Like Fltr Then
            If s Like "[.,бю]" Then KeyAscii = 44
        Else: KeyAscii = 0
        End If
    Case 13:  If Len(txExp) Then txRes = SumProp(txExp)
    Case 8 'Исключения для клавиши BackSpace для удаления
    Case Else: KeyAscii = 0
    End Select
End Sub
Private Sub Form_Load()
    Dim mT&: mT = T
    Set lab = Controls.Add("vb.Label", "lab")
    With lab: .Move L, mT, 0, 0: .AutoSize = 1: .Caption = "Введите сумму и нажмите >Enter ( максимум = 2 147 483 647 )": .Visible = 1
    End With: mT = mT + lab.Height
    Set txExp = Controls.Add("vb.TextBox", "txExp")
    With txExp: .Move L, mT, 0, 0: .Visible = 1: End With: mT = mT + txExp.Height
    Set txRes = Controls.Add("vb.TextBox", "txRes")
    With txRes: .Move L, mT, 0, 0:
    .ToolTipText = "Ctrl+C, Ctrl+X, Ctrl+V, Ctrl+А соответствует командам правки"
    .Visible = 1:  .Locked = 1: End With
End Sub

@KoGG · 07.11.2013, 13:02

Число в пропись для валют, включая копейки , центы и т.д.

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

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
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
Public Function Число_в_текст(ByVal SumBase As Double, ByVal Valuta As String) As String
'Переводит цифровое значение в текстовое предложение.
'Параметр Valuta:
' "руб" - рубли,
' "дол" - доллары,
' "евр" - евро,
' "грив"- гривны,
' "крон"- кроны,
' "" - без наименования,
' прочие текстовые наименования валют используются без склонения.
' Копейки и центы добавляются, если сотые значения присутствуют.
'00 копеек добавляется, если есть дробная чаcть равная или более 0,001
    Dim Edinicy(0 To 19) As String
    Dim Desyatki(0 To 9) As String
    Dim Sotni(0 To 9) As String
    Dim mlrd(0 To 9) As String
    Dim mln(0 To 9) As String
    Dim tys(0 To 9) As String
    Dim SumInt, x, shag, vl As Integer
    Dim txt, Sclon_Tys As String
    Dim Naim_Valuta_1 As String, Naim_Valuta_2 As String, Naim_Valuta_5 As String
    Dim Naim_Sotye_1 As String, Naim_Sotye_2 As String, Naim_Sotye_5 As String
    Dim Sotye As Integer, StrSotye As String
    Dim PereKluch  As String
    '---------------------------------------------
    Application.Volatile
    '---------------------------------------------
    Edinicy(0) = ""
    Edinicy(1) = "один "
    Edinicy(2) = "два "
    Edinicy(3) = "три "
    Edinicy(4) = "четыре "
    Edinicy(5) = "пять "
    Edinicy(6) = "шесть "
    Edinicy(7) = "семь "
    Edinicy(8) = "восемь "
    Edinicy(9) = "девять "
    Edinicy(11) = "одиннадцать "
    Edinicy(12) = "двенадцать "
    Edinicy(13) = "тринадцать "
    Edinicy(14) = "четырнадцать "
    Edinicy(15) = "пятнадцать "
    Edinicy(16) = "шестнадцать "
    Edinicy(17) = "семнадцать "
    Edinicy(18) = "восемнадцать "
    Edinicy(19) = "девятнадцать "
    '---------------------------------------------
    Desyatki(0) = ""
    Desyatki(1) = "десять "
    Desyatki(2) = "двадцать "
    Desyatki(3) = "тридцать "
    Desyatki(4) = "сорок "
    Desyatki(5) = "пятьдесят "
    Desyatki(6) = "шестьдесят "
    Desyatki(7) = "семьдесят "
    Desyatki(8) = "восемьдесят "
    Desyatki(9) = "девяносто "
    '---------------------------------------------
    Sotni(0) = ""
    Sotni(1) = "сто "
    Sotni(2) = "двести "
    Sotni(3) = "триста "
    Sotni(4) = "четыреста "
    Sotni(5) = "пятьсот "
    Sotni(6) = "шестьсот "
    Sotni(7) = "семьсот "
    Sotni(8) = "восемьсот "
    Sotni(9) = "девятьсот "
    '---------------------------------------------
    mlrd(0) = "миллиардов "
    mlrd(1) = "миллиард "
    mlrd(2) = "миллиарда "
    mlrd(3) = "миллиарда "
    mlrd(4) = "миллиарда "
    mlrd(5) = "миллиардов "
    mlrd(6) = "миллиардов "
    mlrd(7) = "миллиардов "
    mlrd(8) = "миллиардов "
    mlrd(9) = "миллиардов "
    '---------------------------------------------
    mln(0) = "миллионов "
    mln(1) = "миллион "
    mln(2) = "миллиона "
    mln(3) = "миллиона "
    mln(4) = "миллиона "
    mln(5) = "миллионов "
    mln(6) = "миллионов "
    mln(7) = "миллионов "
    mln(8) = "миллионов "
    mln(9) = "миллионов "
    '---------------------------------------------
    tys(0) = "тысяч "
    tys(1) = "тысяча "
    tys(2) = "тысячи "
    tys(3) = "тысячи "
    tys(4) = "тысячи "
    tys(5) = "тысяч "
    tys(6) = "тысяч "
    tys(7) = "тысяч "
    tys(8) = "тысяч "
    tys(9) = "тысяч "
    '---------------------------------------------
    On Local Error Resume Next
    shag = 0
    SumInt = Int(SumBase)
    For x = Len(SumInt) To 1 Step -1
        shag = shag + 1
        Select Case x
            Case 12 ' - сотни миллиардов
                vl = Mid(SumInt, shag, 1)
                txt = txt & Sotni(vl)
            Case 11 ' - десятки  миллиардов
                vl = Mid(SumInt, shag, 1)
                If vl = "1" And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo LblNextX Else txt = txt & Desyatki(vl)  ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки
            Case 10 ' - единицы  миллиардов
                vl = Mid(SumInt, shag, 1)
                If shag > 1 Then
                    If Mid(SumInt, shag - 1, 1) = 1 Then txt = txt & Edinicy(Mid(SumInt, shag - 1, 2)) & "миллиардов " Else txt = txt & Edinicy(vl) & mlrd(vl) 'числа в диапозоне от 11 до 19 склоняются на "миллиардов" независимо от последнего числа триады
                Else
                    txt = txt & Edinicy(vl) & mlrd(vl)
                End If
 
                '-КОНЕЦ БЛОКА_______________________
            Case 9 ' - сотни миллионов
                vl = Mid(SumInt, shag, 1)
                txt = txt & Sotni(vl)
            Case 8 ' - десятки  миллионов
                vl = Mid(SumInt, shag, 1)
                If vl = "1" And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo LblNextX Else txt = txt & Desyatki(vl)  ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки
            Case 7 ' - единицы  миллионов
                vl = Mid(SumInt, shag, 1)
                If shag > 2 Then
                    If (Mid(SumInt, shag - 2, 1) = 0 And Mid(SumInt, shag - 1, 1) = 0 And vl = "0") Then GoTo LblNextX
                End If
                If shag > 1 Then
                    If Mid(SumInt, shag - 1, 1) = 1 Then txt = txt & Edinicy(Mid(SumInt, shag - 1, 2)) & "миллионов " Else: txt = txt & Edinicy(vl) & mln(vl)  'числа в диапозоне от 11 до 19 склоняются на "миллиардов" независимо от последнего числа триады
                Else
                    txt = txt & Edinicy(vl) & mln(vl)
                End If
                '-КОНЕЦ БЛОКА_______________________
            Case 6 ' - сотни тысяч
                vl = Mid(SumInt, shag, 1)
                txt = txt & Sotni(vl)
            Case 5 ' - десятки  тысяч
                vl = Mid(SumInt, shag, 1)
                If vl = 1 And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo LblNextX Else txt = txt & Desyatki(vl)  ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки
                Case 4 ' - единицы  тысяч
                vl = Mid(SumInt, shag, 1)
                If shag > 2 Then
                    If (Mid(SumInt, shag - 2, 1) = 0 And Mid(SumInt, shag - 1, 1) = 0 And vl = "0") Then GoTo LblNextX
                End If
                Sclon_Tys = Edinicy(vl) & tys(vl) ' - вводим переменную Sclon_Tys из-за иного склонения  тысяч в русском языке
                If vl = 1 Then Sclon_Tys = "одна " & tys(vl) ' - для тысяч склонение "один" и "два" неприменимо ( поэтому вводим переменную  Sclon_Tys )
                If vl = 2 Then Sclon_Tys = "две " & tys(vl) ' - для тысяч склонение "один" и "два" неприменимо ( поэтому вводим переменную  Sclon_Tys )
                If shag > 1 Then
                    If Mid(SumInt, shag - 1, 1) = 1 Then Sclon_Tys = Edinicy(Mid(SumInt, shag - 1, 2)) & "тысяч "
                End If
                txt = txt & Sclon_Tys
                '-КОНЕЦ БЛОКА_______________________
            Case 3 ' - сотни
                vl = Mid(SumInt, shag, 1)
                txt = txt & Sotni(vl)
            Case 2 ' - десятки
                vl = Mid(SumInt, shag, 1)
                If vl = "1" And Mid(SumInt, shag + 1, 1) <> 0 Then GoTo LblNextX Else txt = txt & Desyatki(vl)  ' - если конец триады от 11 до 19 то перескакиваем на единицы, иначе - формируем десятки
            Case 1 ' - единицы
                vl = Mid(SumInt, shag, 1)
                If shag > 2 Then
                    If (Mid(SumInt, shag - 2, 1) = 0 And Mid(SumInt, shag - 1, 1) = 0 And vl = "0") Then GoTo LblNextX
                End If
                If shag > 1 Then
                    If Mid(SumInt, shag - 1, 1) = 1 Then txt = txt & Edinicy(Mid(SumInt, shag - 1, 2)) Else: txt = txt & Edinicy(vl)
                Else
                    txt = txt & Edinicy(vl)
                End If
                '-КОНЕЦ БЛОКА_______________________
        End Select
LblNextX:
    Next x
    If InStr(1, LCase(Valuta), "руб") > 0 Then Valuta = "рубли"
    If InStr(1, LCase(Valuta), "дол") > 0 Then Valuta = "доллары"
    If InStr(1, LCase(Valuta), "евр") > 0 Then Valuta = "евро"
    If InStr(1, LCase(Valuta), "грив") > 0 Then Valuta = "гривны"
    If InStr(1, LCase(Valuta), "крон") > 0 Then Valuta = "кроны"
    Select Case Valuta
        Case "рубли"
            Naim_Valuta_1 = "рубль"
            Naim_Valuta_2 = "рубля"
            Naim_Valuta_5 = "рублей"
            Naim_Sotye_1 = "копейка"
            Naim_Sotye_2 = "копейки"
            Naim_Sotye_5 = "копеек"
        Case "доллары"
            Naim_Valuta_1 = "доллар"
            Naim_Valuta_2 = "доллара"
            Naim_Valuta_5 = "долларов"
            Naim_Sotye_1 = "цент"
            Naim_Sotye_2 = "цента"
            Naim_Sotye_5 = "центов"
        Case "евро"
            Naim_Valuta_1 = "евро"
            Naim_Valuta_2 = "евро"
            Naim_Valuta_5 = "евро"
            Naim_Sotye_1 = "цент"
            Naim_Sotye_2 = "цента"
            Naim_Sotye_5 = "центов"
        Case "гривны"
            Naim_Valuta_1 = "гривна"
            Naim_Valuta_2 = "гривны"
            Naim_Valuta_5 = "гривен"
            Naim_Sotye_1 = "копейка"
            Naim_Sotye_2 = "копейки"
            Naim_Sotye_5 = "копеек"
        Case "крон"
            Naim_Valuta_1 = "крона"
            Naim_Valuta_2 = "кроны"
            Naim_Valuta_5 = "крон"
            Naim_Sotye_1 = "геллер"
            Naim_Sotye_2 = "геллера"
            Naim_Sotye_5 = "геллеров"
        Case ""
            Naim_Valuta_1 = ""
            Naim_Valuta_2 = ""
            Naim_Valuta_5 = ""
            Naim_Sotye_1 = ""
            Naim_Sotye_2 = ""
            Naim_Sotye_5 = ""
        Case Else
            Naim_Valuta_1 = Valuta
            Naim_Valuta_2 = Valuta
            Naim_Valuta_5 = Valuta
            Naim_Sotye_1 = "сотая"
            Naim_Sotye_2 = "сотых"
            Naim_Sotye_5 = "сотых"
    End Select
    If shag = 1 Then shag = 2
    If vl = 0 Or vl > 4 Or (Mid(SumInt, shag - 1, 2) > 10 And Mid(SumInt, shag - 1, 2) < 20) Then
        txt = txt + Naim_Valuta_5
    Else
        If vl = 1 Then txt = txt + Naim_Valuta_1 Else txt = txt + Naim_Valuta_2
    End If
    Sotye = CInt((SumBase - SumInt) * 100)
    StrSotye = Format(Sotye, "00")
    If CInt((SumBase - SumInt) * 1000) > 0 Then
        txt = txt & " " & StrSotye & " "
        Select Case Left(StrSotye, 1)
            Case "0", "2", "3", "4", "5", "6", "7", "8", "9"
                PereKluch = Right(StrSotye, 1)
            Case Else
                PereKluch = StrSotye
        End Select
        Select Case PereKluch
            Case "1"
                txt = txt & Naim_Sotye_1
            Case "2", "3", "4"
                txt = txt & Naim_Sotye_2
            Case Else
                txt = txt & Naim_Sotye_5
        End Select
    End If
    Число_в_текст = UCase(Left(txt, 1)) & Right(txt, Len(txt) - 1)
End Function
 
Public Function Число_в_текст_руб_коп(Сумма As Currency) As String
    'до 999 999 999 999.99
    On Local Error GoTo RUB_Error
    Dim strРубли As String, strКопейки As String, StrTemp As String
    Dim strМиллиарды As String, strМиллионы As String, strТысячи As String, strЕдиницы As String, strСотые As String
    Dim Поз As Integer
    '---------------------------------------------
    Application.Volatile
    '---------------------------------------------
    
    strРубли = Format(Int(Сумма), "000000000000")
    strКопейки = Format(Int((Сумма - Int(Сумма)) * 100), "00")
    
    'Миллиарды'
    Поз = 1
    strМиллиарды = Сотни(Mid(strРубли, Поз, 1))
    strМиллиарды = strМиллиарды & Десятки(Mid(strРубли, Поз + 1, 2), "м")
    strМиллиарды = strМиллиарды & ИмяРазряда(strМиллиарды, Mid(strРубли, Поз + 1, 2), "миллиард ", "миллиарда ", "миллиардов ")
    
    'Миллионы'
    Поз = 4
    strМиллионы = Сотни(Mid(strРубли, Поз, 1))
    strМиллионы = strМиллионы & Десятки(Mid(strРубли, Поз + 1, 2), "м")
    strМиллионы = strМиллионы & ИмяРазряда(strМиллионы, Mid(strРубли, Поз + 1, 2), "миллион ", "миллиона ", "миллионов ")
    
    'Тысячи'
    Поз = 7
    strТысячи = Сотни(Mid(strРубли, Поз, 1))
    strТысячи = strТысячи & Десятки(Mid(strРубли, Поз + 1, 2), "ж")
    strТысячи = strТысячи & ИмяРазряда(strТысячи, Mid(strРубли, Поз + 1, 2), "тысяча ", "тысячи ", "тысяч ")
    
    'Единицы'
    Поз = 10
    strЕдиницы = Сотни(Mid(strРубли, Поз, 1))
    strЕдиницы = strЕдиницы & Десятки(Mid(strРубли, Поз + 1, 2), "м")
    If strМиллиарды & strМиллионы & strТысячи & strЕдиницы = "" Then strЕдиницы = "ноль "
    strЕдиницы = strЕдиницы & ИмяРазряда(" ", Mid(strРубли, Поз + 1, 2), "рубль ", "рубля ", "рублей ")
    
    
    'Сотые'
    strСотые = strКопейки & " " & ИмяРазряда(strКопейки, Right(strКопейки, 2), "копейка", "копейки", "копеек")
    
    StrTemp = strМиллиарды & strМиллионы & strТысячи & strЕдиницы & strСотые
    Число_в_текст_руб_коп = UCase(Left(StrTemp, 1)) & Right(StrTemp, Len(StrTemp) - 1)
    
    Exit Function
    
RUB_Error:
        MsgBox Err.Description
End Function
 
Private Function Сотни(n As String) As String
    Сотни = ""
    Select Case n
        Case 0: Сотни = ""
        Case 1: Сотни = "сто "
        Case 2: Сотни = "двести "
        Case 3: Сотни = "триста "
        Case 4: Сотни = "четыреста "
        Case 5: Сотни = "пятьсот "
        Case 6: Сотни = "шестьсот "
        Case 7: Сотни = "семьсот "
        Case 8: Сотни = "восемьсот "
        Case 9: Сотни = "девятьсот "
    End Select
End Function
 
Private Function Десятки(n As String, Sex As String) As String
    Десятки = ""
    Select Case Left(n, 1)
        Case "0": Десятки = "": n = Right(n, 1)
        Case "1": Десятки = ""
        Case "2": Десятки = "двадцать ": n = Right(n, 1)
        Case "3": Десятки = "тридцать ": n = Right(n, 1)
        Case "4": Десятки = "сорок ": n = Right(n, 1)
        Case "5": Десятки = "пятьдесят ": n = Right(n, 1)
        Case "6": Десятки = "шестьдесят ": n = Right(n, 1)
        Case "7": Десятки = "семьдесят ": n = Right(n, 1)
        Case "8": Десятки = "восемьдесят ": n = Right(n, 1)
        Case "9": Десятки = "девяносто ": n = Right(n, 1)
    End Select
    
    Dim Двадцатка As String
    Двадцатка = ""
    Select Case n
        Case "0": Двадцатка = ""
        Case "1"
            Select Case Sex
                Case "м": Двадцатка = "один "
                Case "ж": Двадцатка = "одна "
                Case "с": Двадцатка = "одно "
            End Select
        Case "2":
            Select Case Sex
                Case "м": Двадцатка = "два "
                Case "ж": Двадцатка = "две "
                Case "с": Двадцатка = "два "
            End Select
        Case "3": Двадцатка = "три "
        Case "4": Двадцатка = "четыре "
        Case "5": Двадцатка = "пять "
        Case "6": Двадцатка = "шесть "
        Case "7": Двадцатка = "семь "
        Case "8": Двадцатка = "восемь "
        Case "9": Двадцатка = "девять "
        Case "10": Двадцатка = "десять "
        Case "11": Двадцатка = "одиннадцать "
        Case "12": Двадцатка = "двенадцать "
        Case "13": Двадцатка = "тринадцать "
        Case "14": Двадцатка = "четырнадцать "
        Case "15": Двадцатка = "пятнадцать "
        Case "16": Двадцатка = "шестнадцать "
        Case "17": Двадцатка = "семнадцать "
        Case "18": Двадцатка = "восемнадцать "
        Case "19": Двадцатка = "девятнадцать "
    End Select
    
    Десятки = Десятки & Двадцатка
End Function
 
Private Function ИмяРазряда(Строка As String, n As String, Имя1 As String, Имя24 As String, ИмяПроч As String) As String
    If Строка <> "" Then
        ИмяРазряда = ""
        Select Case Left(n, 1)
            Case "0", "2", "3", "4", "5", "6", "7", "8", "9": n = Right(n, 1)
        End Select
        
        Select Case n
            Case "1": ИмяРазряда = Имя1
            Case "2", "3", "4": ИмяРазряда = Имя24
            Case Else: ИмяРазряда = ИмяПроч
        End Select
    End If
End Function

@JoraVoenyjHaker · 16.11.2013, 20:20

Тригонометрия и преобразования

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sec(X) = 1 / Cos(X)
 Cosec(X) = 1 / Sin(X)
 Cotan(X) = 1 / Tan(X)
 Arcsin(X) = Atn(X / Sqr(-X * X + 1))
 Arccos(X) = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
 Arcsec(X) = Atn(X / Sqr(X * X – 1)) + Sgn((X) – 1) * (2 * Atn(1))
 Arccosec(X) = Atn(X / Sqr(X * X - 1)) + (Sgn(X) – 1) * (2 * Atn(1))
 Arccotan(X) = Atn(X) + 2 * Atn(1)
 HSin(X) = (Exp(X) – Exp(-X)) / 2
 HCos(X) = (Exp(X) + Exp(-X)) / 2
 HTan(X) = (Exp(X) – Exp(-X)) / (Exp(X) + Exp(-X))
 HSec(X) = 2 / (Exp(X) + Exp(-X))
 HCosec(X) = 2 / (Exp(X) – Exp(-X))
 HCotan(X) = (Exp(X) + Exp(-X)) / (Exp(X) – Exp(-X))
 HArcsin(X) = Log(X + Sqr(X * X + 1))
 HArccos(X) = Log(X + Sqr(X * X – 1))
 HArctan(X) = Log((1 + X) / (1 – X)) / 2
 HArcsec(X) = Log((Sqr(-X * X + 1) + 1) / X)
 HArccosec(X) = Log((Sgn(X) * Sqr(X * X + 1) + 1) / X)
 HArccotan(X) = Log((X + 1) / (X – 1)) / 2
 LogN(X) = Log(X) / Log(N)

@The trick · 17.11.2013, 00:23

Класс для копирования в отдельном потоке с отображением прогресса
Бывает ситуация, когда нужно скопировать большой файл(ы), при этом стандартная ф-ция FileCopy вешает всю программу до тех пор, пока не закончится копирование. Я разработал класс, в котором используется возможности ф-ции CopyFileEx (использовал ANSI версию), отображение прогресса копирования и возможности отмены, а также многопоточность для запуска всех функций в фоновом потоке.
Класс для копирования в отдельном потоке с отображением прогресса

@The trick · 19.11.2013, 02:49

Гиперкуб (тессеракт)
В программе можно вращать в 6-ти плоскостях гиперкуб, просматривать его перспективную или параллельную проекцию, также оценивать расстояние по оси Т четвертого измерения. Если доработать, то можно будет просматривать и другие четырехмерные фигуры.
4d гиперкуб (тессеракт)

@JoraVoenyjHaker · 22.11.2013, 09:35

Сортировка и поиск
два метода в одном модуле.
Самый быстрый и многозадачный способ из сортировок для бейсика

Ссылка

Сортировка-поиск

@JoraVoenyjHaker · 24.11.2013, 05:06

Уничтожение пробелов

Недавно увидел жалобы некоторых пользователей
у которых не запускалась ActiveX или не был найден файл
по причине пробелов в именах, и решил разместить пару полезных
функций

Модуль

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
Option Explicit
'
'          ©    JoraVoenyjHaker
'
Function VoidFree$(ByVal Text$, Optional ascd As Byte = 92)
    'Уничтожение пустоты между разделителями *
    'Арг: Текст // Asc - код символа по умолчанию [ \ ]
    Dim j$(), s$, f&
    s = Chr$(ascd)
    j = Split(Text, s)
    For f = 0 To UBound(j):  j(f) = Trim(j(f)): Next
    VoidFree = Join(j, s)
End Function
 
Function ReducingGaps$(ByVal Text$, Optional ascd As Byte = 32)
    'Сокращение разрыва *
    'Уничтожает множество пробелов между словами оставляя только 1
    'Арг: Текст // Asc - код символа по умолчанию [пробел]
    Dim chrb2$(1)
    chrb2(0) = Chr$(ascd): chrb2(1) = String(2, ascd)
    While ReducingGaps <> Text
        ReducingGaps = Text
        Text = Replace(Text, chrb2(1), chrb2(0))
    Wend
End Function

@JoraVoenyjHaker · 29.11.2013, 07:55

В Visual Basic 6.0 в отличие от пятой версии окна Code и Object появляются в нормальном, не в раскрытом виде. И приходится при каждом запуске VB6 раскрывать эти окна. Можно заставить автоматически раскрывать эти окна при каждом запуске. Visual Basic 6.0

Значение реестра

[HKEY_CURRENT_USER\Software\Microsoft\Vis ual Basic\6.0]
"MDIMaximized"="1"

Или просто скачать и запустить файл REG

@JoraVoenyjHaker · 01.12.2013, 01:17

Как таскать форму за любое место

Для этого необходимо разместить эти несколько строчек
на любой форме

Модуль формы

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
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 Sub ReleaseCapture Lib "User32" ()
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    Dim ReturnValue As Long
 
    If Button = 1 Then
        Call ReleaseCapture
        ReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

Узнаём о наличие диска в дисководе

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

ссыль из прикольных кодов

@JoraVoenyjHaker · 02.12.2013, 03:02

Следущие 2 примера хочу посвятить важному контролу TextBox

Для работы потребуется форма и обычный компонент с именем Text1

БОЛЬШИЕ или маленькие буквы при вводе

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
'
'   © JoraVoennyjHaker
'
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const ES_UPPERCASE = &H8 ' для больших букв
Private Const ES_LOWERCASE = &H10 ' для маленьких букв
 
Private Sub Form_Load()
    Call SetWindowLong(Text1.hwnd, GWL_STYLE, GetWindowLong(Text1.hwnd, GWL_STYLE) Or ES_UPPERCASE)
End Sub

Второй пример демонстрирует как можно получить количество строк
и текущее положение строки ввода. Необходимые компоненты:
Тот же Text1, только нужно установить MultiLine = True, в окне свойств
и забросить ещё Label1, и Timer1

Количество строк в TextBox и номер текущей строки

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Option Explicit
'
'   © JoraVoennyjHaker
'
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 Const EM_GETLINECOUNT = &HBA, EM_LINEFROMCHAR = &HC9
Dim LebelText$
 
Private Sub Form_Load()
    Timer1.Interval = 100
    Text1 = "" 'Свойство MultiLine = True
End Sub
 
Private Sub Timer1_Timer()
    LebelText = _
    "Всего строк = " & SendMessage(Text1.hWnd, EM_GETLINECOUNT, 0, 0) & vbCrLf & _
    "Номер текущей строки = " & SendMessage(Text1.hWnd, EM_LINEFROMCHAR, Text1.SelStart, 0) + 1
    Label1 = LebelText
End Sub

@JoraVoenyjHaker · 02.12.2013, 18:47

Иконка в трее

кроме иконки которая управляеться с помощю
меню, я ещё вставил код полупрозрачности, MANIFEST (после копиляции)
и добавил звуковых эффектов

@JoraVoenyjHaker · 02.12.2013, 21:52

Утилита для создания шаблона StyleCreator2_2

Отдельное спасибо пользователю The Trick
который помог мне её усовершенствовать

Новые блоги и статьи Все статьи Все блоги /
Запустил конкурс "тем и промптов для текстовых квестов созданных почти чисто ИИ" Adler 06.10.2026 Всем привет! За последние три-четыре дня я создал более 16 текстовых квестовых игр используя преимущественно по одному запросу к ИИ на игру. Мне так понравилось смотреть все ветки/ сцены во всех. . .	ИИ не может найти нужный язык в списке 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, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .

@zink0000 258 / 107 / 26 Регистрация: 15.03.2012 Сообщений: 353 Записей в блоге: 35
	17.10.2013, 10:09
	Перекодировка текстовых файлов из ANSI в Unicode UTF-8 Программа позволяет конвертировать текстовые файлы в заданном каталоге (со всеми вложенными подкаталогами) из кодировки ANSI в Unicode UTF-8, копируя файлы в каталог-результат. win2utf8.zip Может пригодится кому. Внимание! При назначении папки для результатов обратите внимание на сообщение "ВСЕ файлы и ВСЕ папки в этом каталоге будут УДАЛЕНЫ!" Не назначайте в качестве каталога-результата каталог с ценной для Вас информацией! 1

@The trick Модератор 10068 / 3913 / 886 Регистрация: 22.02.2013 Сообщений: 5,863 Записей в блоге: 79
	17.11.2013, 00:23
	Класс для копирования в отдельном потоке с отображением прогресса Бывает ситуация, когда нужно скопировать большой файл(ы), при этом стандартная ф-ция FileCopy вешает всю программу до тех пор, пока не закончится копирование. Я разработал класс, в котором используется возможности ф-ции CopyFileEx (использовал ANSI версию), отображение прогресса копирования и возможности отмены, а также многопоточность для запуска всех функций в фоновом потоке. Класс для копирования в отдельном потоке с отображением прогресса Миниатюры 7

@The trick Модератор 10068 / 3913 / 886 Регистрация: 22.02.2013 Сообщений: 5,863 Записей в блоге: 79
	19.11.2013, 02:49
	Гиперкуб (тессеракт) В программе можно вращать в 6-ти плоскостях гиперкуб, просматривать его перспективную или параллельную проекцию, также оценивать расстояние по оси Т четвертого измерения. Если доработать, то можно будет просматривать и другие четырехмерные фигуры. 4d гиперкуб (тессеракт) Миниатюры 4

@JoraVoenyjHaker Заблокирован
	22.11.2013, 09:35
	Сортировка и поиск два метода в одном модуле. Самый быстрый и многозадачный способ из сортировок для бейсика Ссылка Сортировка-поиск 3