如何使用 VBA 在 Excel 工作簿中存储和检索二进制文件？

问题描述 投票：0回答：1

是否可以在 Excel 工作簿中存储二进制文件以供以后检索？例如任何用户都可以稍后播放的声音文件。

excel vba binaryfiles playsound
1个回答
0
投票

我使用此过程在工作簿中存储和检索二进制文件。它可能对你有用。二进制文件存储在工作簿对象下的CustomDocumentProperties中。由于此属性与字符 &H0000 不兼容，因此首先使用简单的算法对数据进行编码。使用方法如下。

  • 运行 StoreFile(filepath) 以存储工作簿中的任何二进制文件。当任何用户保存并重新打开该文件时，该文件将永久保留在文档中。
  • 运行 GetFile(filename) 检索文件。此函数返回 windows 临时文件夹中“重新创建的文件”的路径。
  • 运行 ClearAll 从工作簿中删除所有文件并清除 windows 临时文件夹中创建的文件。
Option Explicit

Sub StoreFile(ByVal sPath As String)
'Stores the filename given by sPath internally as a CustomDocumentProperty
    Dim fNo As Long, b() As Byte, s As String, sFileName As String
    
'Read the binary file
    fNo = FreeFile
    Open sPath For Binary Access Read As fNo
    ReDim b(LOF(fNo) - 1)
    Get fNo, , b
    Close fNo
    
'Compresses and clears the file from &H0000 (which isn't compatible with CustomDocumentProperties
    s = NonZCompress(b)
    sFileName = Mid(sPath, InStrRev(sPath, "\") + 1) 'Stores the file without "path" information

'Removes any old version of the file
    On Error Resume Next
        ThisWorkbook.CustomDocumentProperties("#BIN:" & sFileName).Delete
    On Error GoTo 0
    
'Adds the propery
    ThisWorkbook.CustomDocumentProperties.Add Name:="#BIN:" & sFileName, LinkToContent:=False, Type:=msoPropertyTypeString, Value:=s
End Sub

Function GetFile(ByVal sFileName As String) As String
'Recreates the file as stored in CustomDocumentProperty in the windows temp folder
'Function returns the path to the recreated file.
'Returns empty string if no file with given filename exists
    Dim CP As DocumentProperty, fNo As Long, b() As Byte, s As String
    
'Clears any path information from user input
    sFileName = Mid(sFileName, InStrRev(sFileName, "\") + 1)
    
'Checks if CustomDocumentProperty exists
    On Error Resume Next
        Set CP = ThisWorkbook.CustomDocumentProperties("#BIN:" & sFileName)
    On Error GoTo 0
    If CP Is Nothing Then Exit Function
    
'Decompresses the file and stores it in byte array b
    b = CP.Value
    b = NonZDecompress(b)
    
'Saves the byte array to the windows temp folder
    GetFile = Environ("temp") & "\" & sFileName
    fNo = FreeFile
    Open GetFile For Binary Access Write As fNo
    Put fNo, , b
    Close fNo
End Function

Sub ClearAll()
'Clears out all created custom properties and removes any temp files
    On Error Resume Next
    While ThisWorkbook.CustomDocumentProperties.Count > 0
        With ThisWorkbook.CustomDocumentProperties(1)
            If Left(.Name, 5) = "#BIN:" Then
                Kill Environ("temp") & "\" & Mid(.Name, 6)
                .Delete
            End If
        End With
    Wend
    On Error GoTo 0
End Sub

为了压缩/解压缩为没有 &H0000 的字节数组，我使用这些函数：

Option Explicit

Function NonZCompress(b() As Byte) As Byte()
    Dim out() As Byte, i_source As Long, i_dest As Long, ZeroSeq As Long, len_b As Long
'Compresses any byte array into a new byte array without &H0000 in it
'First 4 bytes is the length of the input
'Replaces &H0001 with &H0001FFFF
'Replaces any mutiple (N) of &H0000 with &H0001XXXX where XXXX is the number of repeats.
'N ranges from 0 to 65534 (&H0000 to &HFFFE)
    
    ReDim out(UBound(b))
    len_b = UBound(b) + 1
    out(0) = len_b \ 16777216
    out(1) = (len_b Mod 16777216) \ 65536
    out(2) = (len_b Mod 65536) \ 256
    out(3) = len_b Mod 256
    i_dest = 4
    For i_source = 0 To len_b - 1 Step 2
        If b(i_source) = 0 Then
            If b(i_source + 1) = 0 Then '&H0000 found
                If ZeroSeq = 65534 Then
                    'out(i_dest) = 0
                    out(i_dest + 1) = 1
                    out(i_dest + 2) = 255
                    out(i_dest + 3) = 254
                    i_dest = i_dest + 4
                    ZeroSeq = 1
                Else
                    ZeroSeq = ZeroSeq + 1
                End If
            Else  '&H00XX found (XX<>00)
                If ZeroSeq <> 0 Then
                    'out(i_dest) = 0
                    out(i_dest + 1) = 1
                    out(i_dest + 2) = ZeroSeq \ 256
                    out(i_dest + 3) = ZeroSeq Mod 256
                    i_dest = i_dest + 4
                    ZeroSeq = 0
                End If
                If b(i_source + 1) = 1 Then  '&H0001 found
                    'out(i_dest) = 0
                    out(i_dest + 1) = 1
                    out(i_dest + 2) = 255
                    out(i_dest + 3) = 255
                    i_dest = i_dest + 4
                Else  '&H00XX found (XX<>00 and XX<>01)
                    'out(i_dest) = 0
                    out(i_dest + 1) = b(i_source + 1)
                    i_dest = i_dest + 2
                End If
            End If
        Else '&HXXYY found (XX<>00) "normal Word"
            If ZeroSeq <> 0 Then
                'out(i_dest) = 0
                out(i_dest + 1) = 1
                out(i_dest + 2) = ZeroSeq \ 256
                out(i_dest + 3) = ZeroSeq Mod 256
                i_dest = i_dest + 4
                ZeroSeq = 0
            End If
            out(i_dest) = b(i_source)
            out(i_dest + 1) = b(i_source + 1)
            i_dest = i_dest + 2
        End If
        If i_dest + 7 > UBound(out) Then 'Make sure we do not run out of space for next cycle
            ReDim Preserve out(UBound(out) + 100000)
        End If
    Next
    If ZeroSeq <> 0 Then
        'out(i_dest) = 0
        out(i_dest + 1) = 1
        out(i_dest + 2) = ZeroSeq \ 256
        out(i_dest + 3) = ZeroSeq Mod 256
        i_dest = i_dest + 4
        ZeroSeq = 0
    End If

'Special case where byte count is odd. Pad with &HFF
    If (len_b Mod 2) = 1 Then
        out(i_dest) = b(UBound(b))
        out(i_dest + 1) = 255
        i_dest = i_dest + 2
    End If
    
    ReDim Preserve out(i_dest - 1)
    NonZCompress = out
End Function

Function NonZDecompress(b() As Byte) As Byte()
'Decompresses any byte array compressed with NonZCompress
    Dim out() As Byte, i_source As Long, i_dest As Long, ZeroSeq As Boolean, len_b As Long
    
'Set the output size
    ReDim out(b(0) * 16777216 + b(1) * 65536 + b(2) * 256& + b(3) - 1)
    i_dest = 0
    
'Start decompress
    For i_source = 4 To UBound(b) Step 2
        If b(i_source) = 0 And b(i_source + 1) = 1 Then 'Special case &H0001
            i_source = i_source + 2
            If b(i_source) = 255 And b(i_source + 1) = 255 Then 'Signifies the &H0001 should be added
                'out(i_dest) = 0
                out(i_dest + 1) = 1
                i_dest = i_dest + 2
            Else 'Signifies that multiple &H0000 should be added
                i_dest = i_dest + 512& * b(i_source) + 2& * b(i_source + 1)
            End If
        Else 'Normal case
            out(i_dest) = b(i_source)
            If i_dest < UBound(out) Then out(i_dest + 1) = b(i_source + 1) 'The condition is used to handle last odd byte if any
            i_dest = i_dest + 2
        End If
    Next
    NonZDecompress = out
End Function

使用示例。在 Excel 文件中存储一些 Windows 媒体文件，以便根据用户输入播放声音。首先运行 StoreInternally 来存储文件。您只需在工作簿中运行一次。然后使用Sound子播放不同的声音。

Option Explicit

Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Public Enum SOUND_TYPE
    OK = 1
    MISPLACED = 2
    COMPLETE = 3
    NEW_LOCATION = 4
End Enum

Sub Sound(ST As SOUND_TYPE)
    Select Case ST
        Case OK:           sndPlaySound32 GetFile("Windows Ding.wav"), &H1
        Case MISPLACED:    sndPlaySound32 GetFile("Windows Hardware Fail.wav"), &H1
        Case COMPLETE:     sndPlaySound32 GetFile("tada.wav"), &H1
        Case NEW_LOCATION: sndPlaySound32 GetFile("Windows Logon.wav"), &H1
    End Select
End Sub

Sub StoreInternally()
    Const MediaFolder = "C:\Windows\Media\"
    StoreFile MediaFolder & "Windows Ding.wav"
    StoreFile MediaFolder & "Windows Hardware Fail.wav"
    StoreFile MediaFolder & "tada.wav"
    StoreFile MediaFolder & "Windows Logon.wav"
End Sub

希望您觉得这很有用！

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.