clsfile.cls

很好！ 很实用！ 免费！

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const BLOCKSIZE = 4096 '每次读写块的大小
Private Declare Function SHFileExists Lib "shell32" Alias "#45" (ByVal szPath As String) As Long
Private Declare Function getTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Function OpenFile(ByVal hWnd As Long, ByVal sFile As String, ByVal iShow As vbOpenFile)
    OpenFile = ShellExecute(hWnd, "open", sFile, "", "", iShow)
End Function
Public Function ImageToField(ByRef fld As ADODB.Field, DiskFile As String) As Boolean
Dim byteData() As Byte '定义数据块数组
Dim NumBlocks As Long '定义数据块个数
Dim FileLength As Long '标识文件长度
Dim LeftOver As Long '定义剩余字节长度
Dim SourceFile As Long '定义自由文件号
Dim i As Long '定义循环变量
On Error GoTo Err:
    If Not FileExists(DiskFile) Then
        ImageToField = False
        Exit Function
    End If
    SourceFile = FreeFile '提供一个尚未使用的文件号
    Open DiskFile For Binary Access Read As SourceFile '打开文件
    FileLength = LOF(SourceFile) '得到文件长度
    If FileLength = 0 Then '判断文件是否存在
        Close SourceFile
    Else
        NumBlocks = FileLength \ BLOCKSIZE '得到数据块的个数
        LeftOver = FileLength Mod BLOCKSIZE '得到剩余字节数
        fld.value = Null
        ReDim byteData(BLOCKSIZE) '重新定义数据块的大小
        For i = 1 To NumBlocks
            Get SourceFile, , byteData() ' 读到内存块中
            fld.AppendChunk byteData() '写入FLD
            Next i
        ReDim byteData(LeftOver) '重新定义数据块的大小
        Get SourceFile, , byteData() '读到内存块中
        fld.AppendChunk byteData() '写入FLD
        Close SourceFile '关闭源文件
    End If
    ImageToField = True
    Exit Function
Err:
    ImageToField = False
End Function
Public Function FieldToImage(ByVal fld As ADODB.Field, Optional ByVal sType As String = "") As String
  Dim temp_image() As Byte
  Dim image_fileName As String
  If IsNull(fld) Then
    FieldToImage = ""
    Exit Function
  End If
  image_fileName = getVBTempFileName() + IIf(sType = "", "", "." + sType)
  
  temp_image() = fld.value
  
  '建立临时文件
  Open image_fileName For Binary As #1
  Put #1, , temp_image()
  Close #1
  FieldToImage = image_fileName
End Function
Public Function getVBTempFileName() As String
Dim temppath As String  ' receives name of temporary file path
Dim tempfile As String  ' receives name of temporary file
Dim slength As Long  ' receives length of string returned for the path
Dim lastfour As Long  ' receives hex value of the randomly assigned ????
Dim tmpFileName As String
    ' Get Windows's temporary file path
    temppath = Space(255)  ' initialize the buffer to receive the path
    slength = GetTempPath(255, temppath)  ' read the path name
    temppath = Left(temppath, slength)  ' extract data from the variable

    ' Get a uniquely assigned random file
    tempfile = Space(255)  ' initialize buffer to receive the filename
    lastfour = getTempFileName(temppath, "", 0, tempfile)  ' get a unique temporary file name
    ' (Note that the file is also created for you in this case.)
    tempfile = Left(tempfile, InStr(tempfile, vbNullChar) - 1) ' extract data from the variable
    If g_sTempFileName = "" Then
        g_sTempFileName = tempfile
    Else
        g_sTempFileName = g_sTempFileName + "," + tempfile
    End If
    getVBTempFileName = tempfile
End Function
Public Function FileExists(FileName As String) As Boolean
Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
        If fso.FileExists(FileName) Then
            FileExists = True
        Else
            FileExists = False
        End If
    Set fso = Nothing
End Function
Public Sub InitFileList()
    g_sTempFileName = ""
End Sub
Public Sub DisposeFileList()
Dim arrTempFileName() As String
Dim i As Integer
On Error Resume Next
    arrTempFileName = Split(g_sTempFileName, ",")
    For i = 0 To UBound(arrTempFileName)
        Call Kill(arrTempFileName(i))
    Next i
Err.Clear
End Sub