Студопедия

Главная страница Случайная страница

КАТЕГОРИИ:

АвтомобилиАстрономияБиологияГеографияДом и садДругие языкиДругоеИнформатикаИсторияКультураЛитератураЛогикаМатематикаМедицинаМеталлургияМеханикаОбразованиеОхрана трудаПедагогикаПолитикаПравоПсихологияРелигияРиторикаСоциологияСпортСтроительствоТехнологияТуризмФизикаФилософияФинансыХимияЧерчениеЭкологияЭкономикаЭлектроника






Извлечение 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) 'Zlib'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

далее вставляем в код формы следующий код:





Option ExplicitPrivate WithEvents zip As ZipExtractionClassPrivate mCancel As BooleanPrivate Sub Form_Load() Set zip = New ZipExtractionClass If zip.OpenZip("путь к архиву") Then ' пример : C:\1.zip If zip.Extract("куда будет извлекатся", True, True) Then MsgBox "Архив извлечён!", vbInformation ' куда будем извлекать содержимое, пример: C:\из зип архива End If zip.CloseZip End If Set zip = NothingEndEnd Sub

 

Решение уравнения через дискриминант

Сегодня я хочу вам показать как написать программу решения уравнения через дискриминант. Очень полезная программа для учащихся.

  1. Кидаем на форму 3 texboxa
  2. Сверху textbox кидаем три метки Label в них мы указываем буквы a, b, c

В нижней части формы под nextbox кидаем еще з метки Label

  1. В первой метки мы пиставим букву D это будут показывать выходные данные подсчета дискриминанта
  2. Во второй метки Label в низу формы мы пишем X1
  3. И в третей Label пишем X2

Кидаем 2 кнопки одну для выхода а вторую для подсчета дискриминанта

щелкаем на кнопку и вводим такой код

Private Sub Command1_Click()Dim a As DoubleDim b As DoubleDim c As DoubleDim D As DoubleDim x1 As DoubleDim x2 As Doublea = Text1.Textb = Text2.Textc = Text3.TextD = (b ^ 2) - (4 * a * c)If D > 0 Thenx1 = (-D + Sqr(D)) / (2 * a)x2 = (-D - Sqr(D)) / (2 * a)Label7.Caption = "Дискриминант: " & DLabel5.Caption = "Корень X1 = " & x1Label6.Caption = "Корень X2 = " & x2End IfIf D < 0 ThenLabel7.Caption = "Дискриминант:" & DLabel5.Caption = "Корней нет"Label6.Caption = ""MsgBox "Дискриминант больше нуля ", vbCriticalEnd IfEnd Sub

 

Построение графиков квадратичной функций

Сегодня я вам покажу как можно написать программу вычисление графиков функций.

Эта программа строит графики квадратичной функции.

И так притсупим.

  1. Растягиваем форму на половину
  2. Помещаем на форму компонент PIctureBox, наш график будет отображаться на PictureBox
  3. С правой стороны помещаем 3 текстовых поля TextBox, в них мы будем вписывать данные графиков
  4. В нижней части формы помещаем 2 кнопки одну для старта вторую для очистки с формы

И начинаем писать код:

Option ExplicitDim a As SingleDim b As SingleDim c As SingleDim i As IntegerDim y As DoubleDim x As SinglePrivate Sub Command1_Click()Picture1.Scale (-5, 8)-(5, -8)a = Text1.Textb = Text2.Textc = Text3.TextPicture1.Line (-5, 0)-(5, 0), vbBlueFor i = -5 To 5y = x ^ 2 - 2 * x - 3Picture1.PSet (i, 0), vbRedPicture1.Print iNext iPicture1.Line (0, -8)-(0, 8), vbBlueFor i = -8 To 8Picture1.PSet (0, i), vbRedPicture1.Print iNext iFor x = -5 To 5 Step 0.005y = a * x * x + b * x + cPicture1.PSet (x, y), vbRedNextEnd SubPrivate Sub Command2_Click()Text1.Text = ""Text2.Text = ""Text3.Text = ""Picture1.ClsEnd Sub

 

Сохранять и загружать текст

Option Explicit'СОХРАНЯЕМ ТЕКСТ БЕЗ КАВЫЧЕКPrivate Sub Command1_Click()On Error Resume Next 'Если ошибка то продолжаемDim f As LongDim 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 LongDim 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 LongDim 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 LongDim 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 LongDim strText As StringDim 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 & vbCrLfMe.Text1.Text = (strBufText)LoopClose #fEnd Sub'ВАРИАНТ ВТОРОЙPrivate Sub Command6_Click()On Error Resume Next Dim f As LongDim strText As StringDim strBufText As String f = (FreeFile) Open (App.Path & "\Test.txt") For Input As #f 'Открываем файл для чтенияDo Until EOF(f) 'Читаем пока неконецInput #f, strText 'Читаем текст в переменнуюstrBufText = strBufText & strText & vbCrLfMe.Text1.Text = (strBufText)LoopClose #fEnd Sub'ВАРИАНТ ТРЕТИЙPrivate Sub Command7_Click()On Error Resume Next Dim f As LongDim strText As String f = (FreeFile) Open (App.Path & "\Test.txt") For Input As #f 'Открываем файл для чтенияstrText = Input(LOF(f), #f)Me.Text1.Text = (strText)Close #fEnd Sub'ВАРИАНТ ЧЕТВЕРТЫЙ, ОТКРЫВАЕМ НОМЕР УКАЗАННОЙ СТРОКИPrivate Sub Command8_Click()On Error Resume Next Dim f As LongDim i As LongDim strText As String f = (FreeFile) Open (App.Path & "\Test.txt") For Input As #f 'Открываем файл для чтенияFor i = 1 To 8Input #f, strTextMe.Text1.Text = (strText)Next iClose #fEnd Sub'ВАРИАНТ ПЯТЫЙ, ОТКРЫВАЕМ ТЕКСТ КАЖДУЮ СТРОКУ В LISTBOXPrivate Sub Command9_Click()On Error Resume Next Dim f As LongDim i As LongDim 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, strTextMe.List1.AddItem strText, iNext iLoopClose #fEnd Sub

 


mylektsii.ru - Мои Лекции - 2015-2018 год. (0.012 сек.)Все материалы представленные на сайте исключительно с целью ознакомления читателями и не преследуют коммерческих целей или нарушение авторских прав Пожаловаться на материал