Запись кусков байтового массива в файл VB6 - PullRequest
Новая
       36

Запись кусков байтового массива в файл VB6

3 голосов
/ 08 июля 2011

Я ищу эффективный / действенный способ в VB6 взять массив байтов, разделить его на «порции» и записать каждый «порцию» в файл.Причина этого в том, что по мере написания каждого «чанка» я могу позвонить RaiseEvent WriteProgress(BytesDone, BytesTotal), чтобы обновить индикатор выполнения в другом месте.Любые предложения по структуре цикла и т. Д. Высоко ценится.

Ответы [ 3 ]

1 голос
/ 08 июля 2011

CopyMemory - это быстрый способ извлечь кусок массива; 

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal length As Long) As Long

Const CHUNKSIZE = 3&

Dim offset As Long
Dim total  As Long
Dim copied As Long
Dim copy   As Long

Dim testBuff() As Byte: testBuff = StrConv("Klaatubaradanikto", vbFromUnicode)

total = 1 + UBound(testBuff)

'//write buffer
ReDim buff(CHUNKSIZE - 1) As Byte

Open "out.bin" For Binary Access Write As #1

For offset = 0 To -Int(-total / CHUNKSIZE) - 1 '//ghetto round-up
    If (copied + CHUNKSIZE) > total Then
        copy = total - copied
        ReDim buff(copy - 1)
    Else
        copy = CHUNKSIZE
    End If
    '//copy array segment to buffer
    CopyMemory buff(0), testBuff(offset * CHUNKSIZE), copy 
    '//write buffer
    Put #1, , buff

    copied = copied + copy
    Debug.Print offset, "copied:", copied, "of", total
    Next
Close #1
0 голосов
/ 13 июля 2011

немного короче: 

Event WriteProgress(ByVal BytesDone As Long, ByVal BytesTotal As Long)

Public Function WriteChunked(sFileName As String, baData() As Byte, Optional ByVal lChunkSize As Long = 64 * 1024&) As Boolean
    Dim nFile           As Integer
    Dim baChunk()       As Byte

    With CreateObject("ADODB.Stream")
        .Type = 1 ' adTypeBinary
        .Open
        .Write baData
        .Position = 0
        nFile = FreeFile
        Open sFileName For Binary As nFile
        Do While .Position < .Size
            baChunk = .Read(lChunkSize)
            Put nFile, , baChunk
            RaiseEvent WriteProgress(.Position, .Size)
        Loop
        Close nFile
    End With
End Function
0 голосов
/ 09 июля 2011

Я бы сделал небольшой InvisibleAtRuntime = True UserControl, назовите его ChunkWriter. Затем добавьте элемент управления Timer с именем tmrChunk (Enabled = False и Interval = 1) и следующий код: 

Option Explicit

Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80&
Private Const CREATE_ALWAYS As Long = 2
Private Const INVALID_HANDLE_VALUE As Long = -1

Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" ( _
    ByVal lpFileName As Long, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long

Private Declare Function FlushFileBuffers Lib "kernel32" ( _
    ByVal hFile As Long) As Long

Private Declare Function WriteFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As Long, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped As Long) As Long

Private hFile As Long
Private bytCopy() As Byte
Private lngSize As Long
Private lngLB As Long
Private lngChunkSize As Long
Private lngNext As Long
Private lngChunks As Long
Private lngRemainder As Long

Public Event WriteProgress(ByVal BytesWritten As Long, _
                           ByVal BytesTotal As Long, _
                           ByVal Complete As Boolean)

Public Sub WriteChunks( _
    ByVal FileName As String, _
    ByRef Bytes() As Byte, _
    Optional ByVal ChunkSize As Long = 32768)

    If hFile <> INVALID_HANDLE_VALUE Then
        Err.Raise &H8004C700, TypeName(Me), "Already in use"
    End If
    hFile = CreateFile(StrPtr(FileName), GENERIC_WRITE, 0, 0, _
                       CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = INVALID_HANDLE_VALUE Then
        Err.Raise &H8004C702, TypeName(Me), _
                  "Open failed, sys err " & CStr(Err.LastDllError)
    End If
    bytCopy = Bytes 'If Bytes is a String then bytCopy = Bytes, for ANSI use StrConv().
    lngLB = LBound(bytCopy)
    lngSize = UBound(bytCopy) - lngLB + 1
    lngChunkSize = ChunkSize
    lngNext = 0
    lngChunks = lngSize \ lngChunkSize
    lngRemainder = lngSize - (lngChunks * lngChunkSize)
    tmrChunk.Enabled = True
End Sub

Private Sub tmrChunk_Timer()
    Dim lngLen As Long
    Dim lngTemp As Long

    tmrChunk.Enabled = False
    If lngChunks > 0 Then
        lngLen = lngChunkSize
        lngChunks = lngChunks - 1
    Else
        lngLen = lngRemainder
    End If
    If WriteFile(hFile, VarPtr(bytCopy(lngLB + lngNext)), lngLen, _
                 lngTemp, 0) = 0 Then
        lngTemp = Err.LastDllError
        CloseHandle hFile
        hFile = INVALID_HANDLE_VALUE
        Err.Raise &H8004C702, TypeName(Me), _
                  "Write failed, sys err " & CStr(lngTemp)
    End If
    lngNext = lngNext + lngLen

    If lngNext < lngSize Then
        RaiseEvent WriteProgress(lngNext, lngSize, False)
        tmrChunk.Enabled = True
    Else
        FlushFileBuffers hFile
        CloseHandle hFile
        hFile = INVALID_HANDLE_VALUE
        Erase bytCopy
        RaiseEvent WriteProgress(lngNext, lngSize, True)
    End If
End Sub

Private Sub UserControl_Initialize()
    hFile = INVALID_HANDLE_VALUE
End Sub

Private Sub UserControl_Paint()
    Width = 570
    Height = 360
End Sub

Это дает вам ваше событие прогресса без опасности вызовов DoEvents (). Его можно легко изменить, чтобы он принимал String и записывал свои данные либо в Unicode по мере поступления, либо после преобразования ANSI: просто изменение в две строки для WriteChunks ().

...