Форум программистов, компьютерный форум, киберфорум
Наши страницы
Visual Basic
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.60/5: Рейтинг темы: голосов - 5, средняя оценка - 4.60
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
1

Найдите ошибки

10.01.2016, 17:13. Просмотров 857. Ответов 33
Метки нет (Все метки)

Народ, я для собственного саморазвития начал изучать VB (сказали самый легкий язык)... А вообще я юрист))) Изучаю недавно.
Дошел до изучения массивов и манипуляций с файлами. Написал код, который делит файл на три части, а потом собирает его обратно. Код, вроде бы рабочий. Проверял на файлах различных расширений. НО! Я хочу научиться программировать, хотя бы на средняковом уровне, учитывая, что я учусь сам, поэтому прошу Вас помочь мне найти ошибки в коде, подсказать как его писать правильнее, или указать на то, что в коде лишнее и ни в коем случае так делать нельзя и желательно объяснить почему. Спасибо больше заранее, парни.
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
Dim myFile As String
Dim moiMASSIV() As Byte
Dim massivread1() As Byte
Dim massivread2() As Byte
Dim massivread3() As Byte
Dim odnatret As Long
Dim ID As Long
 
 
Private Sub Command1_Click()
myFile = "c:\iskomi.jpg"
    Open myFile For Binary As #1
    odnatret = Int(LOF(1) / 3)
    ReDim moiMASSIV(1 To LOF(1))
        For i = 1 To LOF(1)
            Get #1, i, moiMASSIV(i)
        Next i
 
 
    
    Open "c:\1.txt" For Binary As #2
        For q = 1 To odnatret
            If q <= odnatret Then
                Put #2, q, moiMASSIV(q)
            Else: Exit For
            End If
        Next q
    Close #2
    
   
    
    Open "c:\2.txt" For Binary As #3
        For q = q To (odnatret * 2)
             If q <= (odnatret * 2) Then
                Put #3, (q - odnatret), moiMASSIV(q)
            Else: Exit For
            End If
        Next q
    Close #3
    
 
    
    Open "c:\3.txt" For Binary As #4
        For q = q To LOF(1)
            ID = ID + 1
             If q <= LOF(1) Then
                Put #4, ID, moiMASSIV(q)
            Else: Exit For
            End If
        Next q
    Close #4
    
        Close #1
  ID = 0
  i = 0
 
End Sub
 
Private Sub Command2_Click()
    Open "c:\1.txt" For Binary As #1
    Open "c:\2.txt" For Binary As #2
    Open "c:\3.txt" For Binary As #3
    Open "c:\new.jpg" For Binary As #4
    ReDim massivread1(1 To LOF(1))
    ReDim massivread2(1 To LOF(2))
    ReDim massivread3(1 To LOF(3))
        For i = 1 To LOF(1)
            Get #1, i, massivread1(i)
            Get #2, i, massivread2(i)
            Get #3, i, massivread3(i)
        Next i
        Put #4, , massivread1
        Put #4, , massivread2
        Put #4, , massivread3
    Close #1
    Close #2
    Close #3
    Close #4
 
End Sub
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
10.01.2016, 17:13
Ответы с готовыми решениями:

Найдите ошибку...
Вычислить сумму элементов каждой строки матрицы А, результат отобразить на...

График(найдите ошибку)!!
Picture1.Line (5, 160)-(420, 160) Picture1.Line (210, 50)-(210, 260) ...

Найдите все симметричные Палиндромы
Найдите все симметричные Палиндромы из интервала .Бейсик. Помогите плизз,...

Найдите сумму четных чисел от 1 до N
Найдите сумму четных чисел от 1 до N Visual Basic

Найдите первый отрицательный член последовательности
Дано вещественное положительное число 6. Последовательность a1, a2, a3 ......

33
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
10.01.2016, 21:01 2
Лучший ответ Сообщение было отмечено Catstail как решение

Решение

Первое что бросилось в глаза, это неверное форматирование кода

Добавлено через 5 минут
Обычно отступ ставят после открывающего оператора

тоесть того оператора который обязательно должен закрываться *закрывающим* оператором
например For .. Next Select Case .. Case .. End Select


Во вторых что бросилось в глаза, это непоследовательность команд

Добавлено через 4 минуты
Возможные ошибки в объявлениях массива, обычно по умолчанию нижний индекс
это ноль, при чтении - записи байтовых массивов, также учитываеться что нижний индекс начинаеться с нуля, целесообразнее писать ReDim moiMASSIV(LOF(1)-1) вместо ReDim moiMASSIV(1 To LOF(1))

Добавлено через 4 минуты
.Jpg это бинарный файл изображения, и читать его нужно так:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Function ReadBytes(FileName$, Optional ByRef Start&, Optional ByVal dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Старт // Длина по умолчанию всего файла
    'Возврат: Массив байт и следующая позиция чтения
    Dim n, f: On Error Resume Next
    f = FreeFile
    Open FileName For Binary As #f
    If Start Then Else Start = 1
    n = LOF(f) - Start + 1
    If dln = 0 Or dln > n Then dln = n
    ReDim Preserve ReadBytes(dln - 1)
    Get #f, Start, ReadBytes: Close #f
    If Err = 0 Then Start = Start + UBound(ReadBytes) + 1
End Function
Добавлено через 5 минут
Никаких циклов в чтении бинарного файла не нужно

в моём случае ReadBytes, это функция, которая возвращает байтовый массив
внутри самой функции ReadBytes являеться динамическим массивом

обратите внимание как идёт считывание:
Get #f, Start, ReadBytes: Close #f

f это свободный файловый номер, Start (обычно 1), ReadBytes(байтовый массив),

Close f - Закрытие файла, или отмена его блокировки

Добавлено через 2 минуты
Вобщем ошибок много, мне не охото каждую вашу строчку коментировать и исправлять, до среднякового уровня вам еще далеко
0
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
11.01.2016, 00:45  [ТС] 3
Спасибо большое. Реально очень много нового и интересного. Сейчас попробую все это переварить и применить на практике.
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
11.01.2016, 01:29 4
Цитата Сообщение от Elkatib Посмотреть сообщение
Сейчас попробую все это переварить и применить на практике.
Конечно нужна практика, я обычно как делаю ..
например разрабатываю приложение, столкнулся к примеру с трудностью, делаю правильный запрос в поисковике например так: [Адрессная строка Google] >> Site:CyberForum.ru "For Binary As" or VB6 or VBA -vb.net -c# -c+ -c++ -Delphi

Тоесть, точное совпадение "For Binary As", или со словами VBA, VB6, с исключениями c#, c+ и тд


в итоге, всего три ответа и все по существу

Добавлено через 14 минут
При этом, сложные, готовые проекты, исходники на которые я потратил много часов времени
я стараюсь сразу не выбрасывать, у меня какбэ каталог накапливаеться, при необходимости
можно разыскать и применить в другом проекте, также помогают различные справочники
но у меня их немного, это базовый уровень, и справочники по различным трюкам ..
по звукам, по кнопочкам, по перехвату нажатой клавиши и тд, этого вполне хватает )
0
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
11.01.2016, 01:56  [ТС] 5
Понял. Еще раз спасибо!!!
0
Catstail
Модератор
23604 / 11705 / 2046
Регистрация: 12.02.2012
Сообщений: 19,095
11.01.2016, 11:31 6
Я бы сделал вот так:

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
'::: Разрезать файл на три части
 
Sub Cut_File(finp As String, fo1 As String, fo2 As String, fo3 As String)
Dim fi    As Integer
Dim fo    As Integer
Dim Lf    As Long
Dim Sz    As Long
Dim Buf() As Byte
 
    fi = FreeFile
    Open finp For Binary Access Read As #fi
    
    Lf = LOF(1)
    Sz = Lf \ 3
    ReDim Buf(1 To Sz) As Byte
    
    fo = FreeFile
    Open fo1 For Binary Access Write As #fo
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close fo
    
    fo = FreeFile
    Open fo2 For Binary Access Write As #fo
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close fo
    
    Rest = Lf - 2 * Sz
    
    ReDim Buf(1 To Rest) As Byte
    
    fo = FreeFile
    Open fo3 For Binary Access Write As #fo
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close fo
    Close fi
 
End Sub
 
'::: Склеить их обратно
 
Sub Merge_parts(fout As String, fi1 As String, fi2 As String, fi3 As String)
 
Dim fi    As Integer
Dim fo    As Integer
Dim Lf    As Long
Dim Buf() As Byte
 
    fo = FreeFile
    Open fout For Binary Access Write As #fo
    
    fi = FreeFile
    Open fi1 For Binary Access Read As #fi
    
    Sz = LOF(fi)
    ReDim Buf(1 To Sz) As Byte
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close #fi
    
    fi = FreeFile
    Open fi2 For Binary Access Read As #fi
    
    Sz = LOF(fi)
    ReDim Buf(1 To Sz) As Byte
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close #fi
    
    fi = FreeFile
    Open fi3 For Binary Access Read As #fi
    
    Sz = LOF(fi)
    ReDim Buf(1 To Sz) As Byte
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close #fi
    
    Close #fo
 
End Sub
 
'::: Тестирование в VBA Excel
 
Sub Test()
 
    HomeDir$ = ThisWorkbook.Path
    
    Cut_File HomeDir & "\Cat-117.jpg", HomeDir & "\Cat1.bin", HomeDir & "\Cat2.bin", HomeDir & "\Cat3.bin"
    
    Merge_parts HomeDir & "\Cat-new.jpg", HomeDir & "\Cat1.bin", HomeDir & "\Cat2.bin", HomeDir & "\Cat3.bin"
 
End Sub
Добавлено через 1 минуту

Не по теме:

А что могло сподвигнуть юриста учить программирование?

2
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
11.01.2016, 19:03 7
Access Read и Access Write...

Друг не обращай вимание на эти слова, меня очень напрягает то!, что тебе рассказали
что атрэс должен начинаться с 1. если это вызов ?, то я просто должен ответить
0
Catstail
Модератор
23604 / 11705 / 2046
Регистрация: 12.02.2012
Сообщений: 19,095
11.01.2016, 19:06 8
Цитата Сообщение от fever brain Посмотреть сообщение
Друг не обращай вимание на эти слова
- это про доступ? Зря... Двоичный файл лучше открывать с явным указанием доступа. Если доступ не указать, то можно и читать, и писать (и нечаянно испортить!)
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
11.01.2016, 19:48 9
Лучший ответ Сообщение было отмечено Catstail как решение

Решение

Вот смотри как я реализую запись
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Private Function WriteBytes(FileName$, Bytes() As Byte, Optional ByRef Start&, _
Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    Dim n, f: On Error Resume Next
    If Start Then Else Start = 1
    f = FreeFile 'Определяем номер свободного файла
    If Overwrite Then Kill FileName
    Open FileName$ For Binary As #f: Put #f, 1, Bytes: Close #f 'Копируем !
    If Err = 0 Then WriteBytes = Start + UBound(Bytes) + 1
End Function
Добавлено через 5 минут
Я похожую программу мог бы написать в течении 5 минут,

Заметьте, что в первой функции, что я предложил, можно реально прочитать файл !

но это ерунда ), весь прикол что вс 1 это можно контролировать
например считал половину байт, росмотрел и можешь дальше считывать !

Добавлено через 25 минут
Не должен нулевой индекс начинаться с еденицы, это старческий пережиток !
0
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
11.01.2016, 19:50  [ТС] 10
Парни, я знаю, что прошу о многом, но не могли бы вы прокомментировать каждую строчку кода. Очень прошу. Это все новое для меня и непонятное.
У меня много уголовных дел в производстве, и решил написать для себя прогу с функцией сохранения всех дел с их юридическими особенностям и сроками. А главное, не хочу тупеть. Хочу познать что нибудь новое
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
11.01.2016, 19:58 11
Юрист, если вам не нравится ваше отношение к людям нашего уровня, поймите
я вам не ровня, а уж темболее *Catstail* до него как до луны пешком,
Я Вас не отталкиваю, но осмелюсь спросить а есть ли у вас чтото о чем можно было поговорить ?
0
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
11.01.2016, 20:05  [ТС] 12
Честно признаться, я не понял, что вы имеете в виду?
0
Catstail
Модератор
23604 / 11705 / 2046
Регистрация: 12.02.2012
Сообщений: 19,095
11.01.2016, 20:12 13
Лучший ответ Сообщение было отмечено The trick как решение

Решение

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
'::: Разрезать файл на три части
 
Sub Cut_File(finp As String, fo1 As String, fo2 As String, fo3 As String)
Dim fi    As Integer  ' номер входного файла
Dim fo    As Integer ' номер выходного файла
Dim Lf    As Long  ' длина входного файла
Dim Sz    As Long ' длина трети файла 
Dim Buf() As Byte ' байтовый буфер
 
    fi = FreeFile  ' получаем свободный номер файла
    Open finp For Binary Access Read As #fi ' открываем входной для чтения
    
    Lf = LOF(1)  ' получаем длину входного
    Sz = Lf \ 3  ' делим на 3
    ReDim Buf(1 To Sz) As Byte ' выделяем буфер для очередного куска
    
    fo = FreeFile ' свободный номер файла
    Open fo1 For Binary Access Write As #fo ' открываем для записи
    
    Get #fi, , Buf  'читаем первую треть
    Put #fo, , Buf ' сбрасываем в первый файл
    
    Close #fo  ' закрываем первый выходной
    
    '::: а дальше повторяем еще два раза
 
    fo = FreeFile
    Open fo2 For Binary Access Write As #fo
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close fo
    
    Rest = Lf - 2 * Sz ' длина последней порции может отличаться от остальных
                             ' если Lf не кратно трем
    
    ReDim Buf(1 To Rest) As Byte
    
    fo = FreeFile
    Open fo3 For Binary Access Write As #fo
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close fo
    Close fi  ' закрывем входной
 
End Sub
 
'::: Склеить их обратно
 
Sub Merge_parts(fout As String, fi1 As String, fi2 As String, fi3 As String)
 
Dim fi    As Integer
Dim fo    As Integer
Dim Lf    As Long
Dim Buf() As Byte
 
    fo = FreeFile  ' номер для вых. файла
    Open fout For Binary Access Write As #fo ' открываем...
    
    fi = FreeFile ' номер для первого из входных
    Open fi1 For Binary Access Read As #fi ' открываем
    
    Sz = LOF(fi)  ' определяем длину файла
    ReDim Buf(1 To Sz) As Byte ' выделяем буфер
    
    Get #fi, , Buf   ' читаем буфер
    Put #fo, , Buf  ' сбрасываем в выходной
    
    Close #fi ' закрываем первый входной
    
    '::: Повторяем еще два раза...
 
    fi = FreeFile
    Open fi2 For Binary Access Read As #fi
    
    Sz = LOF(fi)
    ReDim Buf(1 To Sz) As Byte
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close #fi
    
    fi = FreeFile
    Open fi3 For Binary Access Read As #fi
    
    Sz = LOF(fi)
    ReDim Buf(1 To Sz) As Byte
    
    Get #fi, , Buf
    Put #fo, , Buf
    
    Close #fi
    
    Close #fo  ' закрываем выходной
 
End Sub
 
'::: Тестирование в VBA Excel
 
Sub Test()
 
    HomeDir$ = ThisWorkbook.Path
    
    Cut_File HomeDir & "\Cat-117.jpg", HomeDir & "\Cat1.bin", HomeDir & "\Cat2.bin", HomeDir & "\Cat3.bin"
    
    Merge_parts HomeDir & "\Cat-new.jpg", HomeDir & "\Cat1.bin", HomeDir & "\Cat2.bin", HomeDir & "\Cat3.bin"
 
End Sub
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
11.01.2016, 20:13 14
..Я пропущу этот момент, тут спор небольшой между *помогателями* профессионалами
меня наколяет один момент, и не знаю как его побороть ))
но ты не волнуйся, ответ и корректировка твоего задания уже есть !
0
Catstail
Модератор
23604 / 11705 / 2046
Регистрация: 12.02.2012
Сообщений: 19,095
11.01.2016, 20:14 15
Цитата Сообщение от Elkatib Посмотреть сообщение
У меня много уголовных дел в производстве, и решил написать для себя прогу с функцией сохранения всех дел с их юридическими особенностям и сроками. А главное, не хочу тупеть. Хочу познать что нибудь новое
- подход одобряю. Но здесь лучше подошла бы настольная база данных типа аксесса. Можно и в Экселе попробовать. Удачи!
0
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
11.01.2016, 20:32  [ТС] 16
Спасибо ещё раз!!!
0
Elkatib
0 / 0 / 0
Регистрация: 08.01.2016
Сообщений: 103
11.01.2016, 20:58  [ТС] 17
Какой ответ? Что нужно поставить?
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
12.01.2016, 04:07 18
проехали
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
12.01.2016, 16:42 19
Юрист, смотри какую я для тебя программу собрал

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

К примеру в папке у меня иконка и медийный файл Wav, я им поставил
Атрибут системные, и они удаляться не будут


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
Option Explicit
Option Compare Text
'
'Программа для разделения и сборки файлов
'© by the Fever Brain 2016
'
Const r& = 90, gen$ = "prt", stic$ = "cut.ico", jpg = "W.jpg", sl$ = "", t$ = ".", s1$ = "(", s2$ = ")", mxprt& = 20
 
Dim WithEvents cbx1 As ComboBox, WithEvents cbx2 As ComboBox
Dim WithEvents l1 As Label, WithEvents l2 As Label
Dim WithEvents cm1 As CommandButton, WithEvents cm2 As CommandButton
Dim WithEvents ch1 As CheckBox, WithEvents ch2 As CheckBox
Dim WithEvents cm3 As CommandButton, WithEvents ch3 As CheckBox
Dim WithEvents im As Image
Dim m_hMod As Long
Dim ll&, tt&, w&, hh&, i&, mfso As Object, mshapp As Object, dic As Object, fldr$, oldD$, sz&
 
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
 
Private Sub Form_Initialize()
    m_hMod = LoadLibrary("shell32.dll")
    InitCommonControls
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    'Заходим в первоначальную папку, и сохраняем настройки
    ChDir oldD
    SaveSetting "Divisor", "Check", "1", ch1.Value
    SaveSetting "Divisor", "Check", "2", ch2.Value
    SaveSetting "Divisor", "Check", "3", ch3.Value
    FreeLibrary m_hMod
End Sub
 
 
Private Sub cbx1_Click()
    Dim ge As Boolean, fe As Boolean, sys As Boolean
    With fso
        cbx2Ref
        fe = .fileexists(cbx1.Text)
        ge = .GetExtensionName(cbx1.Text) = gen
        sys = .GetFile(cbx1.Text).Attributes And 4 'Если системный
        cm2.Enabled = fe And ge
        cm3.Enabled = fe And (Not cm2.Enabled) And cbx2.ListCount > 0
        cbx2.Enabled = Not (cm2.Enabled)
        ch1.Enabled = fe And (Not ge) And (Not sys)
        ch2.Enabled = fe And ge
    End With
End Sub
 
Private Sub cm3_Click()
    Dim del&, s$, part&, os&, b() As Byte, i&, n&
    'Разбиение
    s = Split(cbx2.Text)(0): If IsNumeric(s) Then del = s
    
    s = ""
    part = sz \ del
    os = sz Mod del
    For i = 1 To sz Step part
        b = ReadBytes(cbx1.Text, (i), part)
        n = n + 1: WriteBytes cbx1.Text & s1 & n & ").prt", b, , 1
    Next
    If i <= sz Then
         b = ReadBytes(cbx1.Text, (i), os)
        n = n + 1: WriteBytes cbx1.Text & s1 & n & ").prt", b, , 1
    End If
    For n = n + 1 To mxprt + 1
        'Удаление частей с высшей нумерацией
        s = cbx1.Text & s1 & n & s2 & t & gen
        If fso.fileexists(s) Then fso.DeleteFile s, 1
    Next
    If ch1.Value > 0 And ch1.Enabled = 1 Then
         'Удаление родительского файла
         fso.DeleteFile cbx1.Text, 1
    End If
    s = cbx1.Text & s1 & 1 & s2 & t & gen
    If fso.fileexists(s) Then cbx1.Text = s
    fldrRef
    If ch3.Value > 0 Then PlaySound "Windows Vista Notify.wav", 0, &H1 Or &H20000
End Sub
 
 
Private Sub cm2_Click()
    'Сборка
    Dim s$(4), ss$, j$(), i&, ii&, start&, b() As Byte
    dic.RemoveAll
    With fso
        s(0) = sss(cbx1.Text, s(1), s(2), s(3), s(4))
        ss = s(4)
        For i = 0 To cbx1.ListCount - 1
            On Error Resume Next
            Erase s
            s(0) = sss(cbx1.List(i), s(1), s(2), s(3), s(4))
            If s(4) = ss And IsNumeric(s(3)) Then dic.Add i, s(0)
        Next
        ii = dic.Count - 1: ReDim j(ii)
        For i = mxprt + 1 To 1 Step -1
            s(0) = ss & s1 & i & s2 & "." & gen
            If .fileexists(s(0)) Then j(ii) = s(0): ii = ii - 1
        Next
    End With
 
    For i = 0 To UBound(j)
        b = ReadBytes(j(i))
        start = WriteBytes(ss, b, (start), i = 0)
         'Удаление
        If ch2.Value = 1 And ch2.Enabled = 1 Then
            fso.DeleteFile j(i), 1
        End If
    Next
 
    
    cbx1.Text = ss
    fldrRef
    If ch3.Value > 0 Then PlaySound "Windows Vista Notify.wav", 0, &H1 Or &H20000
End Sub
 
Function sss(ss0$, ss1$, ss2$, ss3$, ss4$) As String
    'Фильтрация
    With fso
        sss = ss0
        ss1 = .GetExtensionName(ss0)
        ss2 = StrReverse(.GetBaseName(ss0))
        ss3 = Split(Split(ss2, s1, 2)(0), s2, 2)(1)
        ss4 = StrReverse(Split(ss2, s1, 2)(1))
    End With
End Function
 
Sub cbx2Ref()
    With cbx2
        sz = fso.GetFile(cbx1.Text).Size
        cbx1.ToolTipText = "Файл: " & fso.GetAbsolutePathName(cbx1.Text) & "    Размер: " & sz
        .Clear
        For i = mxprt To 2 Step -1
            If (sz \ i) > 0 Then .AddItem i & IIf(i > 3, " Частей", " Части"), 0
        Next
        If .ListCount Then
            .ListIndex = 0
        Else
            .Text = "Разбить нельзя"
        End If
    End With
End Sub
 
Private Sub Form_Resize()
    Me.WindowState = 0
    Me.Width = cm3.Left + cm3.Width + (Me.Width - Me.ScaleWidth) + r * 2
    Me.Height = cm3.Top + cm3.Height + (Me.Height - Me.ScaleHeight) + r * 2
End Sub
 
Private Sub cm1_Click()
    On Error GoTo ext
    fldr = shapp.BrowseForFolder(0, "Текущая, установленная  папка " & vbLf & fldr, 100, "").self.Path
    fldrRef
    cbx1_Click
ext:
End Sub
 
 
Sub fldrRef()
    'Обновление папки
    Dim v, s$
    ChDir fldr
    s = cbx1.Text
    With fso.GetFolder(fldr)
        cbx1.Clear
        For Each v In .Files
            cbx1.AddItem v.Name
        Next
        If fso.fileexists(s) Then cbx1.Text = s: cbx1_Click Else cbx1.ListIndex = 0
    End With
End Sub
 
 
Private Property Get shapp() As Object
    If mshapp Is Nothing Then Set mshapp = CreateObject("Shell.Application")
    Set shapp = mshapp
End Property
 
Private Property Get fso() As Object
    If mfso Is Nothing Then Set mfso = CreateObject("scripting.filesystemobject")
    Set fso = mfso
End Property
 
Private Sub cbx1_KeyPress(KeyAscii As Integer): KeyAscii = 0: End Sub
Private Sub cbx2_KeyPress(KeyAscii As Integer): KeyAscii = 0: End Sub
 
Private Sub Form_Load()
    ll = r: tt = r: w = r * 10: hh = r * 2
    Dim v
    For Each v In Controls: v.Visible = 0: Next
    If fso.fileexists(jpg) Then
        Set im = Controls.Add("vb.image", "im")
        With im
            .Move ll, tt, w, r * 23
            .Stretch = 1
            .Picture = LoadPicture(jpg)
            .Visible = 1
        End With
        ll = ll + w + r
    End If
    Set l1 = Controls.Add("vb.Label", "l1")
    With l1
        .Move ll, tt, w, hh
        .Caption = "Файл:"
        .Visible = 1
    End With
    Set cbx1 = Controls.Add("vb.ComboBox", "cbx1")
    With cbx1
        .Move ll + l1.Width + r, tt, r * 30 ', hh
        .Visible = 1
    End With
    tt = tt + l1.Height + r * 2
    Set l2 = Controls.Add("vb.Label", "l2")
    With l2
        .Move ll, tt, w, hh
        .Caption = "Разбить на:"
        .Visible = 1
    End With
    Set cbx2 = Controls.Add("vb.ComboBox", "cbx2")
    With cbx2
        .Move ll + l1.Width + r, tt, r * 30 ', hh
        .ToolTipText = "Максимум на сколько частей можно разбить этот файл"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    
    Set ch1 = Controls.Add("vb.CheckBox", "ch1")
    With ch1
        .Move ll, tt, r * 40, r * 3
        .Caption = "Удалить родительский файл"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    Set ch2 = Controls.Add("vb.CheckBox", "ch2")
    With ch2
        .Move ll, tt, r * 40, r * 3
        .Caption = "Удалить части"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    Set ch3 = Controls.Add("vb.CheckBox", "ch3")
    With ch3
        .Move ll, tt, r * 40, r * 3
        .Caption = "Звуки"
        .Visible = 1
    End With
    tt = tt + l2.Height + r * 2
    Set cm1 = Controls.Add("vb.CommandButton", "cm1")
    With cm1
        .Move ll, tt, r * 13, r * 3
        .Caption = "Папка .."
        .Visible = 1
    End With
    Set cm2 = Controls.Add("vb.CommandButton", "cm2")
    With cm2
        .Move ll + r * 14, tt, r * 13, r * 3
        .Caption = "Собрать"
        .Visible = 1
    End With
    Set cm3 = Controls.Add("vb.CommandButton", "cm3")
    With cm3
        .Move ll + r * 28, tt, r * 13, r * 3
        .Caption = "Разбить"
        .Visible = 1
    End With
    Set dic = CreateObject("scripting.dictionary")
    dic.CompareMode = 1
    ch1.Value = GetSetting("Divisor", "Check", "1", 0)
    ch2.Value = GetSetting("Divisor", "Check", "2", 0)
    ch3.Value = GetSetting("Divisor", "Check", "3", 1)
    oldD = CurDir$
    ChDir App.Path
    fldr = App.Path
    fldrRef
    cbx1_Click
    On Error Resume Next
    With Me
        .Icon = LoadPicture(stic)
        .Caption = "Разбиение файлов"
        Me.Left = (Screen.Width - Me.Left) / 3
        Me.Top = (Screen.Height - Me.Top) / 3
    End With
End Sub
 
Private Function ReadBytes(FileName$, Optional ByRef start&, Optional ByVal dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Старт // Длина по умолчанию всего файла
    'Возврат: Массив байт и следующая позиция чтения
    Dim n, f: On Error Resume Next
    f = FreeFile
    Open FileName For Binary As #f
    If start Then Else start = 1
    n = LOF(f) - start + 1
    If dln = 0 Or dln > n Then dln = n
    ReDim Preserve ReadBytes(dln - 1)
    Get #f, start, ReadBytes: Close #f
    start = start + UBound(ReadBytes) + 1
End Function
 
Private Function WriteBytes(FileName$, Bytes() As Byte, Optional ByRef start&, _
Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    Dim n, f: On Error Resume Next
    If start Then Else start = 1
    f = FreeFile 'Определяем номер свободного файла
    If Overwrite Then Kill FileName
    Open FileName$ For Binary As #f: Put #f, start, Bytes: Close #f 'Копируем !
    WriteBytes = start + UBound(Bytes) + 1
End Function
0
Миниатюры
Найдите ошибки   Найдите ошибки   Найдите ошибки  

Найдите ошибки  
Вложения
Тип файла: rar Разбиение файлов.rar (162.4 Кб, 4 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
12.01.2016, 17:11 20
И всего, 315 строчек кода ))

Добавлено через 28 минут
Конечно, на создание я потратил более 5 минут,
зато оно того стоит, интуитивно понятный, приятный интерфейс,
+исходник, вот тебе и учеба, там тебе на полгода хватит обучаться ))
1
12.01.2016, 17:11
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
12.01.2016, 17:11

Найдите Пифагоровы числа на заданном отрезке
Найдите Пифагоровы числа на заданном отрезке Причем найти их нужно с...

Найдите максимальный и минимальный элементы массива
Найдите максимальный и минимальный элементы массива из 10 случайных целых...

что не так? найдите ошибку плиз!!!
Товарищи, помоги пожалуйста! 1)Почему у меня в VB6 не воспринимается текст...


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

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

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