Форум программистов, компьютерный форум, киберфорум
Visual Basic
Войти
Регистрация
Восстановить пароль
Блоги Сообщество Поиск  
 
 
Рейтинг 4.53/140: Рейтинг темы: голосов - 140, средняя оценка - 4.53
Эксперт WindowsАвтор FAQ
 Аватар для Dragokas
18035 / 7738 / 892
Регистрация: 25.12.2011
Сообщений: 11,502
Записей в блоге: 16

Тестирование полезных кодов и примеров

15.10.2012, 00:56. Показов 31000. Ответов 301
Метки нет (Все метки)

Студворк — интернет-сервис помощи студентам
Если Ваш код из темы Готовые решения и полезные коды на Visual Basic 6.0

неправильно собран или неработоспособен, он будет перенесен сюда.

Для доведения кода в рабочее состояние в порядке обсуждения создайте новую тему
2
Лучшие ответы (1)
IT_Exp
Эксперт
34794 / 4073 / 2104
Регистрация: 17.06.2006
Сообщений: 32,602
Блог
15.10.2012, 00:56
Ответы с готовыми решениями:

Тестирование полезных скриптов
В этой теме нужно писать: - о багах в выложенных полезных скриптах (закрепленная тема); - ошибках в кодах, на которые ведут ссылки...

Программное тестирование кодов
Доброго! Часто возникает потребность протестить некоторую программку, обычно небольшую. Т.к. в большинстве случаев это надо сделать быстро,...

Cумма кодов четных символов равна сумме кодов нечетных
Даны два поля edit1 и edit2. и кнопка button1. Нужно чтобы при нажатии на кнопку, проверялось: сумма кодов четных символов была равна сумме...

301
145 / 46 / 1
Регистрация: 06.11.2012
Сообщений: 283
29.12.2012, 16:51
Студворк — интернет-сервис помощи студентам
Цитата Сообщение от inv.DS Посмотреть сообщение
E-Mail отправителя
А кое кто думает что мейл получателя
0
Эксперт WindowsАвтор FAQ
 Аватар для Dragokas
18035 / 7738 / 892
Регистрация: 25.12.2011
Сообщений: 11,502
Записей в блоге: 16
29.12.2012, 18:18  [ТС]
Проверил. И так, и так работает.
Так что можно писать:
.Item(v_Conf & "sendusername") = "mail@mail.ru"
Можно просто
.Item(v_Conf & "sendusername") = "mail"
0
 Аватар для Апострофф
9912 / 3933 / 743
Регистрация: 11.10.2011
Сообщений: 5,913
19.01.2013, 12:53
Цитата Сообщение от inv.DS Посмотреть сообщение
Как установить новую дату и время на компьютере?
Visual Basic
1
2
3
4
Sub Set_Date_Time()
Date = DateSerial(2013, 12, 31)
Time = TimeSerial(23, 59, 59)
End Sub
inv.DS, а в чем преимущество Вашего кода?
0
Заблокирован
19.01.2013, 12:55
Апострофф, Он мне понравился !
0
 Аватар для Pro_grammer
6807 / 2839 / 527
Регистрация: 24.04.2011
Сообщений: 5,308
Записей в блоге: 10
19.01.2013, 14:09
Цитата Сообщение от Апострофф Посмотреть сообщение
а в чем преимущество
Я считаю, что главное преимущество этого кода в универсальности - его можно повторить практически на любом современном Языке Программирования. А Ваш код будет работать только на VB
1
 Аватар для Апострофф
9912 / 3933 / 743
Регистрация: 11.10.2011
Сообщений: 5,913
19.04.2013, 10:50
Лучший ответ Сообщение было отмечено как решение

Решение

Текст для теста оформляется по элементарным правилам (достаточно найти и открыть скрытый файл Test.txt в приложенной папке)
Код
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
Option Explicit
 
Sub main()
Dim s As String
Dim a
Dim v
Dim n() As Long
Dim i As Long, j As Long, k As Long
Dim b() As Long
Dim p As Long
Open App.Path & "\Test.txt" For Input As 1
  s = Input$(LOF(1), 1)
Close
a = Split(s, vbCrLf & vbCrLf)
ReDim n(UBound(a))
Randomize
For i = 0 To UBound(n)
  j = Int(Rnd * (i + 1))
  n(i) = n(j)
  n(j) = i
Next i
For i = 0 To UBound(n)
  v = Split(a(n(i)), vbCrLf)
  s = v(0)
  ReDim b(1 To UBound(v))
  For k = 1 To UBound(b)
    j = Int(Rnd * k + 1)
    b(k) = b(j)
    b(j) = k
  Next k
  For k = 1 To UBound(b)
    s = s & vbCrLf & vbCrLf & k & ":  " & v(b(k))
  Next k
  Do
    j = Val(InputBox(s, "Введите номер правильного ответа"))
    If j < 1 Or j > UBound(b) Then
      If MsgBox("Повторить - [Да]" & vbCrLf & "Выйти - [Нет]", vbYesNo, "Не корректный ввод!") <> vbYes Then Exit Sub
    Else
      Exit Do
    End If
  Loop
  p = p - (b(j) = 1)
Next i
MsgBox "Вы дали " & p & " правильных ответов из " & i
End Sub
Миниатюры
Тестирование полезных кодов и примеров  
Вложения
Тип файла: zip test.zip (2.9 Кб, 12 просмотров)
3
19.04.2013, 13:56

Не по теме:

Вопросы сам придумал? Это ппц! :D :rofl:

0
19.04.2013, 14:12

Не по теме:

Цитата Сообщение от Казанский Посмотреть сообщение
Вопросы сам придумал?
Нет, я на такое не горазд:-[
Вот - http://www.hr-portal.ru/pages/hu/logika.php

1
 Аватар для Андрэич
2842 / 774 / 41
Регистрация: 20.05.2012
Сообщений: 2,055
20.04.2013, 00:56
http://www.google.ru/search?cl... el=suggest
0
Модератор
10060 / 3905 / 885
Регистрация: 22.02.2013
Сообщений: 5,854
Записей в блоге: 79
23.04.2013, 21:55
Тест с закодированными вопросами и ответами, с защитой от неправильного изменения.
Миниатюры
Тестирование полезных кодов и примеров  
Вложения
Тип файла: rar TrickTest.rar (43.6 Кб, 24 просмотров)
1
Эксперт WindowsАвтор FAQ
 Аватар для Dragokas
18035 / 7738 / 892
Регистрация: 25.12.2011
Сообщений: 11,502
Записей в блоге: 16
23.04.2013, 23:53  [ТС]
Ув. тов. Апострофф, The trick, не имею понятия, зачем здесь эти тесты.
Тема была создана для проверки кодов на работоспособность, а не выкладывание программ тестирования.

Перенести Ваши примеры в тему: Готовые решения и полезные коды на Visual Basic 6.0
?
0
 Аватар для Апострофф
9912 / 3933 / 743
Регистрация: 11.10.2011
Сообщений: 5,913
24.04.2013, 07:04
Ув. тов. Dragokas, если к коду, оформлению и полезности нет претензий (а написан он был на больную голову), то почему и нет?
0
Модератор
10060 / 3905 / 885
Регистрация: 22.02.2013
Сообщений: 5,854
Записей в блоге: 79
24.04.2013, 09:24
Соглашусь с тов. Апострофф
0
Заблокирован
24.04.2013, 12:32
Товарищи, а не лучше ли переместить данные 2 топика в раздел сборника кодов и примеров где товарищ inv.DS ведет 1 неравный бой!?
0
Эксперт WindowsАвтор FAQ
 Аватар для Dragokas
18035 / 7738 / 892
Регистрация: 25.12.2011
Сообщений: 11,502
Записей в блоге: 16
24.04.2013, 16:34  [ТС]
Просмотрел, проверил.

The trick, очень кропотливая работа. Понравился. Багов не обнаружил.
Апострофф, тоже понравился простотой исполнения. Только стоит добавить, что в файле тестов из 3 ответов верным является первый.
0
3 / 3 / 1
Регистрация: 22.06.2013
Сообщений: 45
08.11.2013, 17:00
Готовые решения и полезные коды на Visual Basic 6.0
Visual Basic
1
2
3
4
5
     Private Sub Command1_Click()  
    'генерирует случайное число от 0 до 99  
    Randomize 'перемешиваем счетчик относительно системного времени
    MsgBox Int(100 * Rnd)  
    End Sub
Наткнулся на примерчик и подумал, что у человека, его ищущего, останутся вопросы типа 'Как это работает?', "А если надо от 5 до 99?'
Ленивые Чай-ники пользуются функцией в общем модуле (в нем хоть полную формулу видно):
Visual Basic
1
2
3
4
5
6
7
Public Function RaNum(minRand As Long, maxRand As Long)  as Long
'генерирует случайное число  до  2147483647
  Randomize        'перемешиваем счетчик относительно системного времени
   RaNum = Int((maxRand - minRand + 1) * Rnd + minRand)
End Function
 
 MsgBox RaNum(0, 99)
0
Заблокирован
09.11.2013, 03:01
chai_nick смотри
Visual Basic
1
2
Randomize timer
MsgBox Int(95 * Rnd)+5
будет вылазить строго от 5 до 99

Добавлено через 1 час 13 минут
Цитата Сообщение от The trick Посмотреть сообщение
Тест с закодированными вопросами и ответами, с защитой от неправильного изменения.
полезная штука !
1
 Аватар для Sapphire
58 / 52 / 0
Регистрация: 15.12.2012
Сообщений: 449
25.12.2013, 08:38
Цитата Сообщение от inv.DS Посмотреть сообщение
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Option Explicit
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Dim p As String
Private Sub Form_Load()
p = "c:\101.mp3"
End Sub
'воспроизводим файл
Private Sub Command2_Click()
Dim f As Long, s As String
s = StrConv(LoadResData(101, "CUSTOM"), vbUnicode)
f = FreeFile
Open p For Binary As #f
Put #f, , s
Close #f
Call mciExecute("play " & p)
End Sub
'стоп
Private Sub Command1_Click()
On Error Resume Next
Call mciExecute("close " & p)
Kill p
End Sub
Код не работает, ибо ресурс 101 не найден. Тестил в хп. В чем причина?

 Комментарий модератора 
Цитата Сообщение от Dragokas Посмотреть сообщение
Запрещаются любые обсуждения выложенных здесь работ (читаем спойлер).
0
es geht mir gut
 Аватар для SoftIce
11274 / 4760 / 1183
Регистрация: 27.07.2011
Сообщений: 11,439
25.12.2013, 08:55
Нужно добавить ресурс
Миниатюры
Тестирование полезных кодов и примеров  
0
 Аватар для Антихакер32
1201 / 473 / 46
Регистрация: 06.01.2014
Сообщений: 1,797
Записей в блоге: 19
17.05.2014, 03:06
Регистрация DLL // OCX с помощью API

с примером и DLL-кой внутри архива

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Option Explicit
'
'© FelixMacintosh 2014
'Регистрация DLL // OCX
'
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long
 
Sub main()
    '
    'Пример регистрации моей dll-ки
    '
    Dim cErr As Object
    ChDir App.Path 'Зайти в папку, где сейчас программа
    Register_OCX_DLL 0, "dllErr.dll", True 'Зарегить
    '
    'Внутренности той dll-ки
    '
    'Public Function Add(Number&, Description$) As Long
    '    'Создаёт номер и дискриптор ошибки
    '    'Возвращает успешно добавленный номер
    'Public Sub Raise(Expression As Boolean, ByVal Index$, Optional Source$)
    '    'Вызов ошибки по указанному индексу
    '    'Арг: выражение // номер или ключ // источник
    '
    'Протестировать её работу
    Set cErr = CreateObject("dllErr.cErr") 'Создать класс
    '
    cErr.Add -2 ^ 16, "Ошибка из за того что ... 2 + 2 = 4"
    cErr.Raise 2 + 2 = 4, -2 ^ 16, "main"
    
    Register_OCX_DLL 0, "dllERR.dll", False 'Отенить регистрацию
End Sub
'
'
'
Public Function Register_OCX_DLL(Wnd As Long, Path As String, Reg As Boolean)
    On Error Resume Next
    Dim lb As Long, pa As Long
    lb = LoadLibrary(Path)
 
    If Reg = True Then
        pa = GetProcAddress(lb, "DllRegisterServer")
    Else
        pa = GetProcAddress(lb, "DllUnregisterServer")
    End If
 
    If pa > 0 Then
        Call CallWindowProc(pa, Wnd, ByVal 0&, ByVal 0&, ByVal 0&)
        Call FreeLibrary(lb)
    End If
End Function
Вложения
Тип файла: rar RegDllOcx.rar (6.2 Кб, 35 просмотров)
2
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
BasicMan
Эксперт
29316 / 5623 / 2384
Регистрация: 17.02.2009
Сообщений: 30,364
Блог
17.05.2014, 03:06

Парочка полезных видеоуроков по C++
323e1ffiYjw AEA7GmPli5Y OH7g2lfsYEU Может какой-нибудь следующий &quot;учитель&quot; посмотрит и передумает делать свои уроки :)

Удаленное тестирование приложение/Пересылка на тестирование
Если кто-то написал приложение под андроид и захочет показать другому человеку, то достаточно отослать apk. А как обстоит с этим дело в...

Unit -тестирование или автоматизированное тестирование
Доброго времени суток. Я программирую «для себя» второй год, на выходе получаются разного рода приложения от постоянно подающих с...

Не Большой Набор Полезных Функций
Функция проверки на наличие не запрещенных символов в поле, где ? - запрещенные символы Function Check_BadSymbols(sStr As String) As...

USBasp - пара возможно полезных плюшек.
Уважаемые коллеги! Возможно то, что я опишу - баян с бородищей. Готов принять справедливую критику. Но вдруг кому-то поможет. Держу...


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

Или воспользуйтесь поиском по форуму:
40
Ответ Создать тему
Новые блоги и статьи
Оказывается, Unreal Engine позволяет качество на порядки выше, чем было в Lineedge
Etyuhibosecyu 05.07.2026
Жаль, конечно, что я не узнал об этом, пока Lineedge существовала, а то бы Noname2331 написал, что волки превращаются в пиксельную кашу, а я бы его попросил скачать какую-нибудь бриллиантовую или Pro. . .
Doom для терминала без стрельбы и монстров. 3D Raycasting на ascii.
dcc0 05.07.2026
Попросил нейронную сеть deepai. org написать рейкастинг 3D с библиотекой ncurses для Linux. Чтобы можно было ходить на стрелочки. Чтобы стены были отрисованы символами. Справилась. Первый вариант. . .
Установка статуса документа по условию
Maks 05.07.2026
Алгоритм из решения ниже реализован на нетиповом документе "НарядПутевка" разработанного в КА2. Задача: в табличной части "Материалы" документа при записи автоматически устанавливать статус. . .
Сезонность и суточность закисления почв
anaschu 04.07.2026
200 часов это все равно моловато. Есть ситуации, но нестандартные, когда смена происходит за 5 лет. Но обычно это 50 лет и более. Наверное, закисление почвы происходит сезонно в средней. . .
В чем ценность человеческого опыта в глобальном смысле?
kumehtar 03.07.2026
Возможно, ценность человека не в том, что он однажды достигает мудрости, а в том, что он становится носителем карты пути. Он знает не только истину, но и последовательность внутренних изменений,. . .
интеграция AnyLogic с самописным REST API и переход на Odoo
anaschu 03.07.2026
Успешная интеграция AnyLogic с самописным REST API и переход на промышленную Odoo WMS Сегодня проделал огромный путь от простой симуляции физических процессов до построения полноценной. . .
Поиск всех путей на ориентированном графе. Linux
dcc0 02.07.2026
Переработка старого кода из моей статьи. Через несколько переработок от PHP кода к C89 (надеюсь, 89). Но довольно запутанно получилось. Код для Linux. Но если убрать time и то, что с ним. . .
Сам себя обучал rest api
anaschu 02.07.2026
Педагогический лайфхак: Почему чистый REST API для ученика намного круче, чем готовые библиотеки Когда мы отказались от капризного JAR-файла AnyLogic и переписали код на стандартный HttpClient,. . .
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2026, CyberForum.ru