Мегапроекты на VB6.0

@kreotodr · Регистрация: 15.08.2014

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

Добрый день!
Коллеги предлагаю делиться не коммерчискими глобальными (и не очень) разработками...
Наверняка у каждого в закромах есть шедевры...

@UBUNTU · 28.09.2017, 11:37

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

@_shark · 28.09.2017, 20:48

хотел ради любопытства посмотреть на "Число прописью", а там какой-то мега-код в 1300 строк с "зашифрованными" комментариями.

@vice4 · 29.09.2017, 11:03

Не моё.

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
' *****************************************************
' Число прописью, данную функцию наваял на Visual Basic 6.0,
'но это все едино. Вызывается примерно так Str = Propis(***число**)
' *****************************************************
Public Function Propis(ByVal nNumber As Long) As String
    Dim ss@, txt$, n%, i%
    Static triad(4) As Integer, numb1(0 To 19) As String, numb2(0 To 9) As String, numb3(0 To 9) As String
    If nNumber = 0 Then
        Propis = "ноль "
        Exit Function
    End If
    ss@ = nNumber
    triad(1) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    triad(2) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    triad(3) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    triad(4) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    numb1(0) = ""
    numb1(1) = "один "
    numb1(2) = "два "
    numb1(3) = "три "
    numb1(4) = "четыре "
    numb1(5) = "пять "
    numb1(6) = "шесть "
    numb1(7) = "семь "
    numb1(8) = "восемь "
    numb1(9) = "девять "
    numb1(10) = "десять "
    numb1(11) = "одиннадцать "
    numb1(12) = "двенадцать "
    numb1(13) = "тринадцать "
    numb1(14) = "четырнадцать "
    numb1(15) = "пятнадцать "
    numb1(16) = "шестнадцать "
    numb1(17) = "семнадцать "
    numb1(18) = "восемнадцать "
    numb1(19) = "девятнадцать "
    numb2(0) = ""
    numb2(1) = ""
    numb2(2) = "двадцать "
    numb2(3) = "тридцать "
    numb2(4) = "сорок "
    numb2(5) = "пятьдесят "
    numb2(6) = "шестьдесят "
    numb2(7) = "семьдесят "
    numb2(8) = "восемьдесят "
    numb2(9) = "девяносто "
    numb3(0) = ""
    numb3(1) = "сто "
    numb3(2) = "двести "
    numb3(3) = "триста "
    numb3(4) = "четыреста "
    numb3(5) = "пятьсот "
    numb3(6) = "шестьсот "
    numb3(7) = "семьсот "
    numb3(8) = "восемьсот "
    numb3(9) = "девятьсот "
    txt$ = ""
    If ss@ <> 0 Then
        n% = MsgBox("Сумма выходит за границы формата", 16, "Сумма прописью")
        Propis = ""
        Exit Function
    End If
    For i% = 4 To 1 Step -1
    n% = 0
    If triad(i%) > 0 Then
    n% = Int(triad(i%) / 100)
    txt$ = txt$ & numb3(n%)
    n% = Int((triad(i%) - n% * 100) / 10)
    txt$ = txt$ & numb2(n%)
    If n% < 2 Then
    n% = triad(i%) - (Int(triad(i%) / 10) - n%) * 10
    Else
    n% = triad(i%) - Int(triad(i%) / 10) * 10
    End If
    Select Case n%
    Case 1
    If i% = 2 Then txt$ = txt$ & "одна " Else txt$ = txt$ & "один "
    Case 2
    If i% = 2 Then txt$ = txt$ & "две " Else txt$ = txt$ & "два"
    Case Else
    txt$ = txt$ & numb1(n%)
    End Select
    Select Case i%
    Case 2
    If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "тысяч "
    Else
    If n% = 1 Then txt$ = txt$ + "тысяча " Else txt$ = txt$ + "тысячи "
    End If
    Case 3
    If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "миллионов "
    Else
    If n% = 1 Then txt$ = txt$ + "миллион " Else txt$ = txt$ + "миллиона "
    End If
    Case 4
    If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "миллиардов "
    Else
    If n% = 1 Then txt$ = txt$ + "миллиард " Else txt$ = txt$ + "миллиарда "
    End If
    End Select
    End If
    Next i%
    txt$ = UCase$(Left$(txt$, 1)) & Mid$(txt$, 2)
    Propis = txt$
End Function

@_shark · 29.09.2017, 11:16

vice4, благодарствую. Не сказать, чтобы она была очень уж мне нужна, я давно еще написал свою, даже более компактную, чем эта. Просто любопытно стало, как можно так растянуть простой, в общем-то, код аж на 1300 строк

@vice4 · 29.09.2017, 11:19

Если программист на "сделке" почему б и не растянуть )

@_shark · 29.09.2017, 11:24

тогда можно почаще пользоваться оператором переноса _ (:

@fever brain · 29.09.2017, 15:43

1096,33
Одна тысяча, девяносто шесть рублей, тридцать три копейки, -Выглядет разумнее ?

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
Option Explicit
'
'   Сумма прописью на русском
'
Const r = 90
Const edn = "ноль один два три четыре пять шесть семь восемь девять"
Const ndc = "одиннадцать двенадцать тринадцать четырнадцать пятнадцать шестнадцать семнадцать восемнадцать девятнадцать"
Const des = "десять двадцать тридцать сорок пятьдесят шестьдесят семьдесят восемьдесят девяносто"
Const sot = "сто двести триста четыреста пятьсот шестьсот семьсот восемьсот девятьсот"
Const tsh = "тысяча тысячи тысяч", mln = "миллион миллиона миллионов", mrd = "миллиард миллиарда миллиардов"
Const rub = "рубль рубля рублей", kop = "копейка копейки копеек"
Dim WithEvents t1 As TextBox, WithEvents t2 As TextBox
Dim s$, a$, k$
 
Private Sub Form_Load()
    Dim t&: t = r
    With Controls.Add("vb.Label", "lab"): .Move r, t, 0, 0: .AutoSize = 1: .Caption = "Введите сумму до 9 знаков": t = t + .Height: .Visible = 1: End With
    Set t1 = Controls.Add("vb.TextBox", "t1"): With t1: .Move r, t, 0, 0: t = t + .Height: .Visible = 1: End With
    Set t2 = Controls.Add("vb.TextBox", "t2"): With t2: .Move r, t, 0, 0: .Visible = 1: .Locked = 1: End With
End Sub
 
Function SumProp$(ByVal Expression As Double, Optional ByVal val$ = rub, Optional rec&)
    Const p = " ", z = ", ":  Dim s$
    If Expression <> Fix(Expression) Then
        k = Mid$(Expression, InStr(1, Expression, ",") + 1, 2)
        k = k & String(2 - Len(k), 48)
        k = z & SumProp(k, kop, 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 <> kop, z, "")
        Case 2, 3, 4: s = s & Split(val)(1) & IIf(rec And val <> kop, z, "")
        Case Else: s = s & Split(val)(2) & IIf(rec And val <> kop, z, "")
        End Select: Select Case val
        Case tsh, kop
            s = Replace(s, "один ", "одна ")
            s = Replace(s, "два ", "две ")
        End Select
    Else: k = Trim$(Mid$(k, 2))
    End If
    If rec = 0 Then s = s & k: k = ""
    SumProp = LCase(s): SumProp = UCase(Left$(SumProp, 1)) & Mid$(SumProp, 2)
End Function
Private Sub Form_Resize()
    On Error Resume Next
    With t1: .Move .Left, .Top, ScaleWidth - r * 2, 0: End With
    With t2: .Move .Left, .Top, ScaleWidth - r * 2, 0: End With
End Sub
 
Sub View(KeyAscii%, obj As TextBox)
    With obj
        Select Case KeyAscii
        Case 1: .SelStart = 0: .SelLength = 2 ^ 15
        Case 3: Clipboard.Clear: Clipboard.SetText .SelText
        Case 24: If Len(.SelText) Then Clipboard.Clear: Clipboard.SetText .SelText: .SelText = ""
        Case 22: .SelText = Clipboard.GetText: KeyAscii = 0
        End Select
    End With
End Sub
 
Private Sub t1_KeyPress(KeyAscii As Integer)
    a = Choose(Sgn(InStr(1, t1, ",")) + 1, "[0-9.,бю]", "[0-9]")
    s = Chr(KeyAscii)
    Select Case KeyAscii
    Case Is > 31
        If s Like a Then
            If s Like "[.,бю]" Then KeyAscii = 44
        Else: KeyAscii = 0
        End If
    Case 13:  If Len(t1) Then t2 = SumProp(t1)
    Case 8
    Case Else: View KeyAscii, t1: KeyAscii = 0
    End Select
End Sub
Private Sub t2_GotFocus(): t2.SelStart = 0: t2.SelLength = Len(t2): End Sub
Private Sub t2_KeyPress(KeyAscii As Integer): View KeyAscii, t2: End Sub

@fever brain · 29.09.2017, 16:38

Не по теме:

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

@fever brain · 29.09.2017, 16:58

---

@Alex77755 · 29.09.2017, 20:34

Не моё.

Но автор указан. Вот, действительно, образец как надо делать!

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
Function MSumProp$(chislo#) 'Автор MCH (Михаил Ч.), май 2012
Dim rub$, kop$, ed, des, sot, nadc, razr, i&, m$
If chislo >= 1E+15 Or chislo < 0 Then Exit Function
 
sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
razr = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "рубль ", "рубля ", "рублей ")
 
rub = Left(Format(chislo, "000000000000000.00"), 15)
kop = Right(Format(chislo, "0.00"), 2)
 
If CDbl(rub) = 0 Then m = "ноль "
For i = 1 To Len(rub) Step 3
    If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
        m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, razr(i + 1), IIf(Mid(rub, i + 2, 1) = "1", razr(i - 1), razr(i)))
    End If
Next i
MSumProp = UCase(Left(m, 1)) & Mid(m, 2) & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек", IIf(kop Mod 10 = 1, "йка", "йки"))
End Function

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Реализация движения на Box2D v3 - трение и коллизии с повёрнутыми стенами 8Observer8 20.02.2026 Содержание блога Box2D позволяет легко создать главного героя, который не проходит сквозь стены и перемещается с заданным трением о препятствия, которые можно располагать под углом, как верхнее. . .	Конвертировать закладки radiotray-ng в m3u-плейлист damix 19.02.2026 Это можно сделать скриптом для PowerShell. Использование . \СonvertRadiotrayToM3U. ps1 <path_to_bookmarks. json> Рядом с файлом bookmarks. json появится файл bookmarks. m3u с результатом. # Check if. . .	Семь CDC на одном интерфейсе: 5 U[S]ARTов, 1 CAN и 1 SSI Eddy_Em 18.02.2026 Постепенно допиливаю свою "многоинтерфейсную плату". Выглядит вот так: https:/ / www. cyberforum. ru/ blog_attachment. php?attachmentid=11617&stc=1&d=1771445347 Основана на STM32F303RBT6. На борту пять. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .
И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»	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. Пошагово создадим проект для загрузки изображения. . .

@kreotodr 39 / 39 / 8 Регистрация: 15.08.2014 Сообщений: 634

	Мегапроекты на VB6.0 28.09.2017, 10:53. Показов 769. Ответов 10 Метки нет (Все метки) Добрый день! Коллеги предлагаю делиться не коммерчискими глобальными (и не очень) разработками... Наверняка у каждого в закромах есть шедевры... 0

@UBUNTU 352 / 213 / 42 Регистрация: 04.02.2015 Сообщений: 1,344
	28.09.2017, 11:37
	Готовые решения и полезные коды на Visual Basic 6.0 Последние страницы полистайте. 0

@_shark 193 / 191 / 31 Регистрация: 11.10.2016 Сообщений: 610
	28.09.2017, 20:48
	хотел ради любопытства посмотреть на "Число прописью", а там какой-то мега-код в 1300 строк с "зашифрованными" комментариями. 0

@_shark 193 / 191 / 31 Регистрация: 11.10.2016 Сообщений: 610
	29.09.2017, 11:16
	vice4, благодарствую. Не сказать, чтобы она была очень уж мне нужна, я давно еще написал свою, даже более компактную, чем эта. Просто любопытно стало, как можно так растянуть простой, в общем-то, код аж на 1300 строк 0

@vice4 28 / 28 / 4 Регистрация: 07.06.2017 Сообщений: 166
	29.09.2017, 11:19
	Если программист на "сделке" почему б и не растянуть ) 0

@_shark 193 / 191 / 31 Регистрация: 11.10.2016 Сообщений: 610
	29.09.2017, 11:24
	тогда можно почаще пользоваться оператором переноса _ (: 0