VB 实现数据库 字段与文件 互转

 1. 字段下载为文件

'判断服务器是否存在 标准管脚图块 和 标准盲栓图块（在 标准块 表内）
If rs.State Then rs.Close
rs.Open "Select BlkFile From 标准块 Where BlkName='导通管脚块'", ConnIP, adOpenForwardOnly, adLockReadOnly
If rs.EOF Then MsgBox "在服务器上没有发现标准[导通管脚块].", vbOKOnly + vbInformation, "错误提示": Exit Sub
If IsNull(rs("BlkFile")) Then MsgBox "服务器上的标准[导通管脚块]没有上传图块.", vbOKOnly + vbInformation, "错误提示": Exit Sub
GJBlkFile = App.Path & "\Temp\GJBlk.dwg"
If Not BlobToFile(rs("BlkFile"), GJBlkFile) Then MsgBox "下载[导通管脚块]文件失败.", vbOKOnly + vbInformation, "错误提示": Exit Sub


'将字段内容 存为 文件
Public Function BlobToFile(fld As ADODB.Field, FileName As String) As Boolean
On Error GoTo Err_BlobToFile
Dim FNum As Integer, bytesLeft As Long, bytes As Long
Dim tmp() As Byte
BlobToFile = False
If (fld.Attributes And adFldLong) = 0 Then
    Err.Raise 1001, , "DwgPic 字段不支持输出文件. "
End If
If Dir$(FileName) <> "" Then Kill FileName '原来的删了
FNum = FreeFile
Open FileName For Binary As FNum
    bytes = fld.ActualSize
    tmp = fld.GetChunk(bytes)
    Put #FNum, , tmp
Close #FNum
BlobToFile = True
Exit Function
Err_BlobToFile:
    If MsgBox("错误:" & Err.Description & vbCrLf & "是否继续？", vbYesNo + vbInformation + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
    Close #FNum
End Function

2. 文件上传到数据库字段

'将文件存入 字段内
Public Function FileToBlob(fld As ADODB.Field, FileName As String, Optional ChunkSize As Long) As Boolean
On Error GoTo Err_FileToBlob
Dim FNum As Integer, bytesLeft As Long, bytes As Long, tmp() As Byte
If ChunkSize = 0 Then ChunkSize = FileLen(FileName)
If (fld.Attributes And adFldLong) = 0 Then
    Err.Raise 1001, , "二进制字段不支持存入文件. "
End If
FNum = FreeFile
Open FileName For Binary As FNum
bytesLeft = LOF(FNum)
Do While bytesLeft
    bytes = bytesLeft
    If bytes > ChunkSize Then bytes = ChunkSize
    ReDim tmp(1 To bytes) As Byte
    Get #1, , tmp
    fld.AppendChunk tmp
    bytesLeft = bytesLeft - bytes
Loop
Close #FNum
FileToBlob = True
Exit Function
Err_FileToBlob:
    FileToBlob = False
End Function


Private Sub Cmd_UpCDwg_Click()
On Error GoTo Err_ABC
Dim FileName As String, rs As New ADODB.Recordset
If Not HasModiRight(1) Then Exit Sub
If LVBZBlk.SelectedItem Is Nothing Then MsgBox "请选择要上传块文件对应的辅材.", vbOKOnly + vbInformation, "上传提示": Exit Sub
If Not ConCAD Then Exit Sub
If acadApp.ActiveDocument Is Nothing Then MsgBox "请在AutoCAD内首先打开要上传的图块文件.", vbOKOnly + vbInformation, "上传辅材图块": Exit Sub
Call DelBindTempObj '删除 临时对象
'清理图形中 无用的 文字样式 和 图层
acadApp.ActiveDocument.Save
FileName = acadApp.ActiveDocument.Path & "\" & acadApp.ActiveDocument.name
rs.Open "Select ID,BlkFile,SaveTime From 标准块 Where ID=" & Val(LVBZBlk.SelectedItem.Tag), ConnIP, adOpenDynamic, adLockOptimistic
If rs.EOF Then MsgBox "获取当前选择标准块记录失败.", vbOKOnly + vbCritical, "上传CAD图到选择标准块提示": Exit Sub
If Not IsNull(rs("BlkFile")) Then '当前标准块 已经上传有图形,询问是否继续上传
    If MsgBox("标准块(" & LVBZBlk.SelectedItem.Text & ")已经上传有图块." & vbCrLf & "是否将AutoCAD当前文档作为其图块？", vbYesNo + vbDefaultButton2, "覆盖确认") = vbNo Then Exit Sub
End If
Call FileToBlob(rs("BlkFile"), FileName, FileLen(FileName))
LVBZBlk.SelectedItem.SubItems(2) = Format(Now, "YYYY-MM-DD HH:MM:SS")
rs("SaveTime") = LVBZBlk.SelectedItem.SubItems(2)
rs.Update: rs.Close
MsgBox "上传当前CAD图到标准块(" & LVBZBlk.SelectedItem.Text & ")成功.", vbOKOnly + vbInformation, "上传提示"
Exit Sub
Err_ABC:
    If MsgBox("错误:" & Err.Description & vbCrLf & "是否继续?", vbYesNo + vbInformation + vbDefaultButton1, "错误处理") = vbYes Then Resume Next
End Sub