Главная страница Случайная страница
Разделы сайта
АвтомобилиАстрономияБиологияГеографияДом и садДругие языкиДругоеИнформатикаИсторияКультураЛитератураЛогикаМатематикаМедицинаМеталлургияМеханикаОбразованиеОхрана трудаПедагогикаПолитикаПравоПсихологияРелигияРиторикаСоциологияСпортСтроительствоТехнологияТуризмФизикаФилософияФинансыХимияЧерчениеЭкологияЭкономикаЭлектроника
💸 Как сделать бизнес проще, а карман толще?
⚡️ Для новых пользователей первый месяц бесплатно. А далее 290 руб/мес, это в 3 раза дешевле аналогов. За эту цену доступен весь функционал: напоминание о визитах, чаевые, предоплаты, общение с клиентами, переносы записей и так далее.
✅ Уйма гибких настроек, которые помогут вам зарабатывать больше и забыть про чувство «что-то мне нужно было сделать».
Сомневаетесь? нажмите на текст, запустите чат-бота и убедитесь во всем сами!
Извлечение zip архива без архиваторов и сторонних программ
|
|
Мы знаем что формат архивации zip, windows может открыть и без архиваторов и сторонних программ(если не знали теперь знаем), его спокойно откоет windows xp, и windows 7 на других не пробывал. Решил я написать апдейтер большого количества файлов, а заливать их на фтп по штучно неудобно да и вобщем ненужно =).
К форме надо добавить модуль класса:
Проэкт => Добавить модуль класса => Модуль класса
И называем его: ZipExtractionClass
В модуль вписываем следующий код:
Option Explicit Private fh As Long Private Declare Function CopyMemory Lib " kernel32" Alias " RtlMoveMemory" (dest As Any, src As Any, ByVal length As Long) As LongPrivate Declare Function lstrcpy Lib " kernel32" Alias " lstrcpyA" (ByVal lpBuffer As String, ByVal lpString As Long) As LongPrivate Declare Function lstrlen Lib " kernel32" Alias " lstrlenA" (ByVal lpString As Long) As Long Private Declare Function ZLibVer Lib " zlib" Alias " zlibVersion" () As LongPrivate Declare Function Compress Lib " zlib.dll" Alias " compress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As LongPrivate Declare Function Compress2 Lib " zlib.dll" Alias " compress2" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long, ByVal Level As Long) As LongPrivate Declare Function UnCompress Lib " zlib.dll" Alias " uncompress" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As LongPrivate Declare Function lCRC32 Lib " zlib.dll" Alias " crc32" (ByVal crc As Long, Buffer As Any, ByVal length As Long) As Long Public Enum eZipError zeZLibNotInstalled = 1 zeNotZipFile = 2 zeNoOpenZipFile = 3 zeUnsupportedCompressionMethod = 4 zeChecksumError = 5 zeFileNotFound = 10 zeFileAlreadyExists = 11 zeCantRemoveFile = 12 zeCantCreateFolder = 13End Enum Private Type typCentralFileHeader CentralFileHeaderSigniature As Long VersionMadeBy As Integer VersionNeededToExtract As Integer GeneralPurposeBitFlag As Integer CompressionMethod As Integer LastModFileTime As Integer LastModFileDate As Integer CRC32 As Long CompressedSize As Long UnCompressedSize As Long FileNameLength As Integer ExtraFieldLength As Integer FileCommentLength As Integer DiskNumberStart As Integer InternalFileAttributes As Integer ExternalFileAttributes As Long RelativeOffsetOfLocalHeader As LongEnd Type Private Type typCenteralDirEnd EndOFCentralDirSignature As Long NumberOfThisDisk As Integer NumberOfDiskWithCentralDir As Integer EntriesInTheCentralDirThisOnDisk As Integer EntriesInTheCentralDir As Integer SizeOfCentralDir As Long OffSetOfCentralDir As Long ZipFileCommentLength As IntegerEnd Type Private Type typLocalFileHeader LocalFileHeaderSignature As Long VersionNeededToExtract As Integer GeneralPurposeBitFlag As Integer CompressionMethod As Integer LastModFileTime As Integer LastModFileDate As Integer CRC32 As Long CompressedSize As Long UnCompressedSize As Long FileNameLength As Integer ExtraFieldLength As IntegerEnd Type Private Const EndOFCentralDirSignature As Long = & H6054B50Private Const CentralFileHeaderSigniature As Long = & H2014B50Private Const LocalFileHeaderSignature As Long = & H4034B50 Private CentralFileHeader As typCentralFileHeaderPrivate CentralDirEnd As typCenteralDirEnd Private CentralDirEndPos As Long Public Event Progress(Percent As Long, Cancel As Boolean)Public Event Status(Text As String)Public Event ZipError(Number As eZipError, Description As String) Public Function OpenZip(ZipPath As String) As Boolean RaiseEvent Status(" Opening Zip") CloseZip If Not FileExists(ZipPath) Then RaiseEvent ZipError(zeFileNotFound, " The file " & ZipPath & " doesn't exist") Exit Function End If fh = FreeFile Open ZipPath For Binary As #fh CentralDirEndPos = GetCentralDirEndPos(fh) If CentralDirEndPos > 0 Then OpenZip = True RaiseEvent Status(" Zip Opened") Else RaiseEvent ZipError(zeNotZipFile, " The file " & ZipPath & " is not a Zip file") End If End Function Public Sub CloseZip() If fh < > 0 Then Close #fh fh = 0 RaiseEvent Status(" Zip Closed") End If CentralDirEndPos = 0 End Sub Public Function Extract(FolderPath As String, Optional PreservePath As Boolean, Optional Overwrite As Boolean) As Boolean Dim l As Long Dim FileName As String Dim FilePos As Long Dim Cancel As Boolean If Len(ZLibVersion) = 0 Then Exit Function End If RaiseEvent Status(" Extracting Files") If CentralDirEndPos = 0 Then RaiseEvent ZipError(zeNoOpenZipFile, " There is no Zip File Open") Exit Function End If If Not FolderExists(FolderPath) Then If Not CreateFolder(FolderPath) Then RaiseEvent ZipError(zeCantCreateFolder, " Can't create the folder " & FolderPath) Exit Function End If End If If ReadCentralDirEnd(CentralDirEndPos) Then Seek #fh, CentralDirEnd.OffSetOfCentralDir + 1 For l = 1 To CentralDirEnd.EntriesInTheCentralDir ReadCentralFileHeader FileName If CentralFileHeader.UnCompressedSize > 0 Then If PreservePath Then CheckFolder FolderPath, GetFilePath(FileName) Else FileName = GetFileName(FileName) End If RaiseEvent Status(" Extracting...\" & FileName) FilePos = Seek(fh) If FileExists(FolderPath & " \ " & FileName) Then If Overwrite Then If RemoveFile(FolderPath & " \ " & FileName) Then ExtractFile FolderPath & " \ " & FileName Else RaiseEvent ZipError(zeCantRemoveFile, " Can 't remove the file " & FolderPath & " \" & FileName) End If Else RaiseEvent ZipError(zeFileAlreadyExists, " The file " & FolderPath & " \" & FileName & " already exists") End If Else ExtractFile FolderPath & " \" & FileName End If Seek fh, FilePos End If DoEvents RaiseEvent Progress((l / CentralDirEnd.EntriesInTheCentralDir) * 100, Cancel) If Cancel Then Exit Function End If Next Extract = True End If RaiseEvent Status(" Extraction Complete") End Function Private Function GetFileName(Path As String) As String Dim l As Long l = InStrRev(Path, " \") If l > 0 Then GetFileName = Right$(Path, Len(Path) - l) Else GetFileName = Path End If End Function Private Function GetFilePath(Path As String) As String Dim l As Long l = InStrRev(Path, " \") If l > 0 Then GetFilePath = Left$(Path, l - 1) End If End Function Private Sub CheckFolder(ByVal FolderPath As String, CheckPath As String) Dim s() As String Dim v As Variant s = Split(CheckPath, " \") For Each v In s FolderPath = FolderPath & " \" & v If Not FolderExists(FolderPath) Then MkDir FolderPath End If Next End Sub Private Sub ReadCentralFileHeader(FileName As String) Dim ExtraField As String Dim Comment As String Get #fh,, CentralFileHeader If CentralFileHeader.CentralFileHeaderSigniature = CentralFileHeaderSigniature Then FileName = Space(CentralFileHeader.FileNameLength) Get #fh,, FileName FileName = Replace(FileName, " /", " \") ExtraField = Space(CentralFileHeader.ExtraFieldLength) Get #fh,, ExtraField Comment = Space(CentralFileHeader.FileCommentLength) Get #fh,, Comment End If End Sub Private Function ReadCentralDirEnd(Position As Long) As Boolean Dim l As Long Dim ZipComment As String Get #fh, Position, CentralDirEnd ZipComment = Space(CentralDirEnd.ZipFileCommentLength) Get #fh,, ZipComment ReadCentralDirEnd = CentralDirEnd.NumberOfThisDisk = CentralDirEnd.NumberOfDiskWithCentralDir End Function Private Function ExtractFile(Path As String) As Boolean Dim LocalFileHeader As typLocalFileHeader Dim b() As Byte Dim FileName As String Dim ExtraField As String Get #fh, CentralFileHeader.RelativeOffsetOfLocalHeader + 1, LocalFileHeader If LocalFileHeader.LocalFileHeaderSignature = LocalFileHeaderSignature Then FileName = Space(LocalFileHeader.FileNameLength) Get #fh,, FileName ExtraField = Space(LocalFileHeader.ExtraFieldLength) Get #fh,, ExtraField ReDim b(LocalFileHeader.CompressedSize - 1) Get #fh,, b If CentralFileHeader.CompressionMethod = 0 Then ' No Compression SaveFile Path, b ElseIf CentralFileHeader.CompressionMethod = 8 Then 'Deflate Method If UnCompressBytes(b, LocalFileHeader.CompressedSize, LocalFileHeader.UnCompressedSize, LocalFileHeader.CRC32) Then SaveFile Path, b Else RaiseEvent ZipError(zeChecksumError, " Data checksum error in " & Path) End If Else RaiseEvent ZipError(zeUnsupportedCompressionMethod, " The compression Method for " & FileName & " is unsupported") End If End If End Function Private Function FileExists(Path) As Boolean FileExists = Not (Len(Dir$(Path, vbNormal)) = 0) End Function Private Function FolderExists(Path) As Boolean FolderExists = Not (Len(Dir$(Path, vbDirectory)) = 0) End Function Private Function CreateFolder(Path As String) As Boolean On Error GoTo eh MkDir Path CreateFolder = True eh: End Function Private Function RemoveFile(Path As String) As Boolean On Error GoTo eh Kill Path RemoveFile = True eh: End Function Private Function GetCentralDirEndPos(fh As Long) As Long Dim Data() As Byte Dim l As Long Dim m As Long ReDim Data(LOF(fh) - 1) Get #fh,, Data For l = UBound(Data) - 3 To LBound(Data) Step -1 CopyMemory m, Data(l), 4 If m = EndOFCentralDirSignature Then GetCentralDirEndPos = l + 1 Exit Function End If Next End Function Private Function UnCompressBytes(Buffer() As Byte, CompressedSize As Long, UnCompressedSize As Long, CRC32 As Long) As Boolean Dim b() As Byte Dim BufferSize As Long Dim FileSize As Long Dim crc As Long Dim fh As Long Dim r As Long ReDim b(UBound(Buffer) + 2) ' Zli b's Uncompress method expects the 2 byte head that the Compress method adds ' so we put that on first. Luckily it 's always the same value. b(0) = 120 b(1) = 156 CopyMemory b(2), Buffer(0), UBound(Buffer) + 1 FileSize = UBound(Buffer) + 3 BufferSize = CentralFileHeader.UnCompressedSize * 1.01 + 12 ReDim Buffer(BufferSize - 1) As Byte r = UnCompress(Buffer(0), BufferSize, b(0), FileSize) ReDim Preserve Buffer(CentralFileHeader.UnCompressedSize - 1) crc = lCRC32(0&, Buffer(0), UBound(Buffer) + 1) If crc = CRC32 Then UnCompressBytes = True End If End Function Private Sub SaveFile(Path As String, Data() As Byte) Dim lfh As Long lfh = FreeFile Open Path For Binary As #lfh Put #lfh,, Data Close #lfh End Sub Private Function PointerToString(Pointer As Long) As String Dim l As Long Dim s As String l = lstrlen(Pointer) s = Space(l) l = lstrcpy(s, Pointer) If l > 0 Then PointerToString = s End If End Function Public Property Get ZLibVersion() As String On Error GoTo eh ZLibVersion = PointerToString(ZLibVer) Exit Propertyeh: RaiseEvent ZipError(zeZLibNotInstalled, " Zlib is not installed") End Property Private Sub Class_Terminate() CloseZip End Subдалее вставляем в код формы следующий код:
Решение уравнения через дискриминант
Сегодня я хочу вам показать как написать программу решения уравнения через дискриминант. Очень полезная программа для учащихся.
- Кидаем на форму 3 texboxa
- Сверху textbox кидаем три метки Label в них мы указываем буквы a, b, c
В нижней части формы под nextbox кидаем еще з метки Label
- В первой метки мы пиставим букву D это будут показывать выходные данные подсчета дискриминанта
- Во второй метки Label в низу формы мы пишем X1
- И в третей Label пишем X2
Кидаем 2 кнопки одну для выхода а вторую для подсчета дискриминанта
щелкаем на кнопку и вводим такой код
Private Sub Command1_Click() Dim a As Double Dim b As Double Dim c As Double Dim D As Double Dim x1 As Double Dim x2 As Doublea = Text1.Textb = Text2.Textc = Text3.TextD = (b ^ 2) - (4 * a * c) If D > 0 Then x1 = (-D + Sqr(D)) / (2 * a)x2 = (-D - Sqr(D)) / (2 * a)Label7.Caption = " Дискриминант: " & DLabel5.Caption = " Корень X1 = " & x1Label6.Caption = " Корень X2 = " & x2 End IfIf D < 0 Then Label7.Caption = " Дискриминант: " & DLabel5.Caption = " Корней нет" Label6.Caption = " " MsgBox " Дискриминант больше нуля ", vbCritical End IfEnd Sub
Построение графиков квадратичной функций
Сегодня я вам покажу как можно написать программу вычисление графиков функций.
Эта программа строит графики квадратичной функции.
И так притсупим.
- Растягиваем форму на половину
- Помещаем на форму компонент PIctureBox, наш график будет отображаться на PictureBox
- С правой стороны помещаем 3 текстовых поля TextBox, в них мы будем вписывать данные графиков
- В нижней части формы помещаем 2 кнопки одну для старта вторую для очистки с формы
И начинаем писать код:
Option ExplicitDim a As Single Dim b As Single Dim c As Single Dim i As Integer Dim y As Double Dim x As Single Private Sub Command1_Click()Picture1.Scale (-5, 8)-(5, -8)a = Text1.Textb = Text2.Textc = Text3.TextPicture1.Line (-5, 0)-(5, 0), vbBlue For i = -5 To 5y = x ^ 2 - 2 * x - 3Picture1.PSet (i, 0), vbRedPicture1.Print i Next iPicture1.Line (0, -8)-(0, 8), vbBlue For i = -8 To 8Picture1.PSet (0, i), vbRedPicture1.Print i Next i For x = -5 To 5 Step 0.005y = a * x * x + b * x + cPicture1.PSet (x, y), vbRed NextEnd SubPrivate Sub Command2_Click()Text1.Text = " " Text2.Text = " " Text3.Text = " " Picture1.Cls End Sub
Сохранять и загружать текст
Option Explicit 'СОХРАНЯЕМ ТЕКСТ БЕЗ КАВЫЧЕК Private Sub Command1_Click() On Error Resume Next 'Если ошибка то продолжаем Dim f As Long Dim strText As String strText = (Me. Text1.Text)f = (FreeFile) Open (App.Path & " \Test.txt") For Output As #f 'Открываем файл для записи Print #f, strText 'Сохраняем текст Close #f 'Закрываем MsgBox " Текст сохранен", vbInformation, " Info..." Exit Sub 'Выходим из процедуры End Sub 'СОХРАНЯЕМ ТЕКСТ В КАВЫЧЬКАХ Private Sub Command2_Click() On Error Resume Next 'Если ошибка то продолжаем Dim f As Long Dim strText As String strText = (Me. Text1.Text)f = (FreeFile) Open (App.Path & " \Test.txt") For Output As #f 'Открываем файл для записи Write #f, strText 'Сохраняем текст Close #f 'Закрываем MsgBox " Текст сохранен", vbInformation, " Info..." Exit Sub 'Выходим из процедуры End Sub 'СОХРАНЯЕМ ТЕКСТ БЕЗ КАВЫЧЕК В КОНЦЕ ТЕКСТА Private Sub Command3_Click() On Error Resume Next 'Если ошибка то продолжаем Dim f As Long Dim strText As String strText = (Me. Text1.Text)f = (FreeFile) Open (App.Path & " \Test.txt") For Append As #f 'Открываем файл для записи Print #f, strText 'Сохраняем текст Close #f 'Закрываем MsgBox " Текст сохранен", vbInformation, " Info..." Exit Sub 'Выходим из процедуры End Sub 'СОХРАНЯЕМ ТЕКСТ В КАВЫЧЬКАХ В КОНЦЕ ТЕКСТА Private Sub Command4_Click() On Error Resume Next 'Если ошибка то продолжаем Dim f As Long Dim strText As String strText = (Me. Text1.Text)f = (FreeFile) Open (App.Path & " \Test.txt") For Append As #f 'Открываем файл для записи Write #f, strText 'Сохраняем текст Close #f 'Закрываем MsgBox " Текст сохранен", vbInformation, " Info..." Exit Sub 'Выходим из процедуры End Sub '=============================================================================================='ОТКРЫВАЕМ ТЕКСТОВЫЕ ФАЙЛЫ'ВОТ НЕСКОЛЬКО ПРИМЕРОВ ОТКРЫВАТЬ ТЕКСТ ПОЛНОСТЬЮ'ТУТ ЖЕ МОЖНО ПРОПИСАТЬ LINE INPUT ДЛЯ ПОКАЗА КАВЫЧЕК В ТЕКСТЕ ЕСЛИ ОНИ ТАМ ЕСТЬ'ВАРИАНТ ПЕРВЫЙ Private Sub Command5_Click() On Error Resume Next Dim f As Long Dim strText As String Dim strBufText As String f = (FreeFile) Open (App.Path & " \Test.txt") For Input As #f 'Открываем файл для чтения Do While Not EOF(f) 'Читаем пока неконец Input #f, strText 'Читаем текст в переменную strBufText = strBufText & strText & vbCrLf Me. Text1.Text = (strBufText) Loop Close #f End Sub 'ВАРИАНТ ВТОРОЙ Private Sub Command6_Click() On Error Resume Next Dim f As Long Dim strText As String Dim strBufText As String f = (FreeFile) Open (App.Path & " \Test.txt") For Input As #f 'Открываем файл для чтения Do Until EOF(f) 'Читаем пока неконец Input #f, strText 'Читаем текст в переменную strBufText = strBufText & strText & vbCrLf Me. Text1.Text = (strBufText) Loop Close #f End Sub 'ВАРИАНТ ТРЕТИЙ Private Sub Command7_Click() On Error Resume Next Dim f As Long Dim strText As String f = (FreeFile) Open (App.Path & " \Test.txt") For Input As #f 'Открываем файл для чтения strText = Input(LOF(f), #f) Me. Text1.Text = (strText)Close #f End Sub 'ВАРИАНТ ЧЕТВЕРТЫЙ, ОТКРЫВАЕМ НОМЕР УКАЗАННОЙ СТРОКИ Private Sub Command8_Click() On Error Resume Next Dim f As Long Dim i As Long Dim strText As String f = (FreeFile) Open (App.Path & " \Test.txt") For Input As #f 'Открываем файл для чтения For i = 1 To 8Input #f, strText Me. Text1.Text = (strText) Next iClose #f End Sub 'ВАРИАНТ ПЯТЫЙ, ОТКРЫВАЕМ ТЕКСТ КАЖДУЮ СТРОКУ В LISTBOX Private Sub Command9_Click() On Error Resume Next Dim f As Long Dim i As Long Dim strText As String f = (FreeFile) Open (App.Path & " \Test.txt") For Input As #f 'Открываем файл для чтения Do Until EOF(f) For i = 0 To EOF(f) Step 1Input #f, strText Me. List1.AddItem strText, i Next i Loop Close #f End Sub
|
|