Форум программистов, компьютерный форум CyberForum.ru

Visual Basic

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
KoGG
5261 / 1333 / 314
Регистрация: 23.12.2010
Сообщений: 2,014
Записей в блоге: 1
24.10.2013, 20:33 #46
Шахматы.
Вложения
Тип файла: zip Chess_KoGG.zip (305.9 Кб, 104 просмотров)
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
24.10.2013, 20:33
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Готовые решения и полезные коды на Visual Basic 6.0 (Visual Basic):

Продам готовые коды и решения на Visual Basic за 400 рублей - Visual Basic
душу продаю:cry: Продам коды исходные на VB !!10 лет копил за 400р !!размер тока кодов 312метров там есть все ! мыло контакты удалены....

Коды на Visual Basic - Visual Basic
Ребята всем привет,я начел изучать "Visual Basic"! Очень буду благодарен за коды по этому языку, очень интиресный язык)))! Бросайте сюда...

Вывод решения вместо Immediate в textbox (visual basic 6.0) - Visual Basic
программа выводит решение в Immediate а я хочу разместить на форме text1 и что бы решение выводилось туда ,менял код менял не че не...

Вычисление значений функции двух переменных в Visual Basic - Visual Basic - Visual Basic
Помогите пожалуйста! В среде VB написать программу вычисления значений функции двух переменных. Ориентировочный вид окна программы и...

Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net ? - Visual Basic
Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net

Visual Basic Используя условный оператор if…then, if…then…else или if…then…elseif, разработайте проект для решения следующих заданий: - Visual Basic
Пройдет ли кирпич со сторонами а, b и с сквозь прямоугольное отверстие со сторонами p и q? Стороны отверстия должны быть параллельны граням...

Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
JoraVoenyjHaker
Заблокирован
24.10.2013, 22:59 #47
Оптимизатор текста (цветной)

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

Скриншот:
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar MasterVB.rar (164.7 Кб, 121 просмотров)
JoraVoenyjHaker
Заблокирован
28.10.2013, 00:37 #48
Относительные пути

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

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

Код для модуля формы:
Кликните здесь для просмотра всего текста
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


Скриншот:
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Антихакер32
Заблокирован
07.11.2013, 08:22 #49
Сумма прописью

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



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
5261 / 1333 / 314
Регистрация: 23.12.2010
Сообщений: 2,014
Записей в блоге: 1
07.11.2013, 13:02 #50
Число в пропись для валют, включая копейки , центы и т.д.
Кликните здесь для просмотра всего текста
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 #51
Тригонометрия и преобразования

Кликните здесь для просмотра всего текста
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
Модератор
7185 / 2417 / 741
Регистрация: 22.02.2013
Сообщений: 3,473
Записей в блоге: 74
17.11.2013, 00:23 #52
Класс для копирования в отдельном потоке с отображением прогресса
Бывает ситуация, когда нужно скопировать большой файл(ы), при этом стандартная ф-ция FileCopy вешает всю программу до тех пор, пока не закончится копирование. Я разработал класс, в котором используется возможности ф-ции CopyFileEx (использовал ANSI версию), отображение прогресса копирования и возможности отмены, а также многопоточность для запуска всех функций в фоновом потоке.
Класс для копирования в отдельном потоке с отображением прогресса
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
The trick
Модератор
7185 / 2417 / 741
Регистрация: 22.02.2013
Сообщений: 3,473
Записей в блоге: 74
19.11.2013, 02:49 #53
Гиперкуб (тессеракт)
В программе можно вращать в 6-ти плоскостях гиперкуб, просматривать его перспективную или параллельную проекцию, также оценивать расстояние по оси Т четвертого измерения. Если доработать, то можно будет просматривать и другие четырехмерные фигуры.
4d гиперкуб (тессеракт)
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
JoraVoenyjHaker
Заблокирован
22.11.2013, 09:35 #54
Сортировка и поиск
два метода в одном модуле.
Самый быстрый и многозадачный способ из сортировок для бейсика


JoraVoenyjHaker
Заблокирован
24.11.2013, 05:06 #55
Уничтожение пробелов

Недавно увидел жалобы некоторых пользователей
у которых не запускалась 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 #56
В Visual Basic 6.0 в отличие от пятой версии окна Code и Object появляются в нормальном, не в раскрытом виде. И приходится при каждом запуске VB6 раскрывать эти окна. Можно заставить автоматически раскрывать эти окна при каждом запуске. Visual Basic 6.0

Значение реестра
[HKEY_CURRENT_USER\Software\Microsoft\Visual Basic\6.0]
"MDIMaximized"="1"


Или просто скачать и запустить файл REG
Вложения
Тип файла: zip 6.0.zip (271 байт, 46 просмотров)
JoraVoenyjHaker
Заблокирован
01.12.2013, 01:17 #57
Как таскать форму за любое место

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


Модуль формы
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 #58
Следущие 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 #59
Иконка в трее

кроме иконки которая управляеться с помощю
меню, я ещё вставил код полупрозрачности, MANIFEST (после копиляции)
и добавил звуковых эффектов
Вложения
Тип файла: zip Иконка в трее.zip (3.9 Кб, 73 просмотров)
JoraVoenyjHaker
Заблокирован
02.12.2013, 21:52 #60
Утилита для создания шаблона StyleCreator2_2

Отдельное спасибо пользователю The Trick
который помог мне её усовершенствовать
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip StyleCreator2_2.zip (308.7 Кб, 77 просмотров)
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
02.12.2013, 21:52
Привет! Вот еще темы с ответами:

Visual Basic 6 и Visual Basic .NET - в чем различия? - Visual Basic
Visual Basic и Visual studio это не одно и тоже? если нет то в чём разница, по мимо оформления?

Отличия версий Visual Basic 6.0 от Visual Basic 6.5? - Visual Basic
У меня 3 вопроса: 1.Чем отличается версия Visual Basic 6.0 от Visual Basic 6.5? 2.Можно ли запустить проект созданный раннее в Visual...

Кто пишет программы в Visual Studio 2010 на Visual Basic? - Visual Basic
Кто пишет программы в Visual Studio 2010 на Visual Basic?

Проблема с установкой Visual Studio вообще и Visual Basic - Visual Basic
Точнее, с установкой Visual Studio вообще и Visual Basic в частности. В самом конце установки, при setup is updating your system,...


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

Или воспользуйтесь поиском по форуму:
Yandex
Объявления
02.12.2013, 21:52
Ответ Создать тему
Опции темы

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