一卡通产品介绍：首页-一卡通设备批发-淘宝网淘宝, 店铺, 旺铺, 一卡通设备批发https://shop73172356.taobao.com/
将图片文件保存到MSSQL数据库的Image类型
Private Sub Image1_DblClick()
On Error GoTo OpenCancel
Dim rst As New ADODB.Recordset
Dim bytedata() As Byte
Dim NumBlocks As Long
Dim FileLength As Long
Dim LeftOver As Long
Dim SourceFile As Long
Const Blocksize = 4096
Dim i As Long
Dim answ As Long
If Trim(Text4.Text) <> "" Then
rst.CursorLocation = adUseClient
rst.Open "select * from zg where zgbh='" & Trim(Text4.Text) & "'", cn, adOpenDynamic, adLockOptimistic
If rst.RecordCount > 0 Then
ComDialog.Filter = "JPG文件 (*.jpg)|*.jpg|BMP文件 (*.bmp)|*.bmp|GIF文件 (*.gif)|*.gif|所有文件 *.*|*.*"
ComDialog.InitDir = App.Path & "\"
ComDialog.ShowOpen
If Trim(ComDialog.filename) <> "" Then
Image1.Picture = LoadPicture(Trim(ComDialog.filename))
SourceFile = FreeFile
Open Trim(ComDialog.filename) For Binary Access Read As SourceFile
FileLength = LOF(SourceFile)
If FileLength = 0 Then
Close SourceFile
Else
answ = MsgBox("是否要保存当前的相片？", vbQuestion + vbOKCancel, "提示：")
If answ = vbOK Then
NumBlocks = FileLength \ Blocksize
LeftOver = FileLength Mod Blocksize
ReDim bytedata(Blocksize)
For i = 1 To NumBlocks
Get SourceFile, , bytedata()
rst.Fields("phon").AppendChunk bytedata()
Next i
ReDim bytedata(LeftOver)
Get SourceFile, , bytedata()
rst.Fields("phon").AppendChunk bytedata()
Close SourceFile
rst.Update
Else
Close SourceFile
Image1.Picture = LoadPicture("")
End If
End If
End If
End If
Else
MsgBox "请先选择一位持卡人后，再为其选择保存相片！", vbCritical, "提示："
End If
Exit Sub
OpenCancel:
End Sub读取MSSql数据库的Image字段中的图片文件并显示?
Private Sub dispphon()
On Error GoTo OpenCancel
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open "select * from zg where zgbh='" & Trim(Text4.Text) & "'", cn, adOpenDynamic, adLockOptimistic
Image1.Picture = LoadPicture("")
If Not IsNull(rst.Fields("phon")) Then
Dim stm As ADODB.Stream
Set stm = New ADODB.Stream
stm.Type = adTypeBinary
stm.Open
stm.Write rst.Fields("phon").Value
stm.SaveToFile App.Path & "\temp.jpg", adSaveCreateOverWrite
stm.Close
Set stm = Nothing
Image1.Picture = LoadPicture(App.Path & "\temp.jpg")
Exit Sub
Else
Image1.Picture = Image3.Picture
End If
Exit Sub
OpenCancel:
stm.Close
Set stm = Nothing
End Sub将文件保存到MYSQL数据库的MediumBlob类型
Public Sub UpFile(ByVal Upfilestr As String, fileid As Integer)
Dim FilName As String
Dim thiscn As New ADODB.Connection
Dim mysqlstor As New ADODB.Command
Dim newid As Long
Dim bytedata() As Byte
Dim NumBlocks As Long
Dim FileLength As Long
Dim LeftOver As Long
Dim SourceFile As Long
Const Blocksize = 4096
On Error GoTo err1
DoEvents
FilName = Upfilestr
thiscn.Open thiscnstr
If thiscn.State = 1 Then
If Len(Dir(FilName)) > 0 Then
Dim fver As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fver = fso.GetFileVersion(FilName) '获得现在文件的版本号
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open "select Id,FileSize,FileInfoBit,FileVer from prtscsys where id=" & fileid, thiscn, adOpenDynamic, adLockOptimistic
If rst.RecordCount > 0 Then
GetFileNum = FreeFile
Open FilName For Binary Access Read As GetFileNum
FileLength = LOF(GetFileNum)
If FileLength = 0 Then
Close GetFileNum
Else
NumBlocks = FileLength \ Blocksize
LeftOver = FileLength Mod Blocksize
ReDim bytedata(Blocksize)
For i = 1 To NumBlocks
Get GetFileNum, , bytedata()
rst.Fields("FileInfoBit").AppendChunk bytedata()
Next i
ReDim bytedata(LeftOver)
Get GetFileNum, , bytedata()
rst.Fields("FileInfoBit").AppendChunk bytedata()
rst.Fields("FileSize") = FileLength
rst.Fields("FileVer") = fver
rst.Update
Close GetFileNum
End If
End If
End If
thiscn.Close
End If
Exit Sub
err1:
thiscn.Close
Close GetFileNum
End Sub读取保存在MYSQL数据库MediumBlob字段内的文件?
Public Sub DownFile(ByVal fileid As Integer)
Dim thiscn As New ADODB.Connection
Dim Length As Long
Dim WinHandle
Dim SendInf As String
Dim qqWindow As String * 26
Dim ParHandle As Long
Dim Ustr As String
Dim myClassName As String
On Error GoTo err1
DoEvents
thiscn.Open thiscnstr
If thiscn.State = 1 Then
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
DoEvents
rst.Open "select FileInfoBit from prtscsys where Id=" & fileid, thiscn, adOpenDynamic, adLockOptimistic
If Not IsNull(rst.Fields("FileInfoBit")) Then
Dim stm As ADODB.Stream
Set stm = New ADODB.Stream
stm.Type = adTypeBinary
stm.Open
stm.Write rst.Fields("FileInfoBit").Value
If fileid = 1 Then
stm.SaveToFile runexefile, adSaveCreateOverWrite
ElseIf fileid = 2 Then
stm.SaveToFile jianchfile, adSaveCreateOverWrite
End If
stm.Close
Set stm = Nothing
End If
thiscn.Close
End If
Exit Sub
err1:
thiscn.Close
End Sub
