1,216
社区成员
发帖
与我相关
我的任务
分享
Option Explicit
Dim Conn As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim streamImg As New ADODB.Stream
Dim strSQL As String
Dim strConn As String
Private Sub cmdGet_Click()
strConn = "Driver=SQL Server;Server=.;uid=sa;Pwd=123456;Database=ImgTest"
Conn.ConnectionString = strConn
Conn.CommandTimeout = 10
Conn.Open
strSQL = "Select * from ImgTest Where IID=" & txtImg.Text
RS.Open strSQL, Conn, adOpenStatic, adLockReadOnly
If RS.RecordCount > 0 Then
streamImg.Open
streamImg.Type = adTypeBinary
streamImg.Write RS("Img")
streamImg.SaveToFile App.Path & "\aa.jpg", adSaveCreateOverWrite
Image1.Picture = LoadPicture(App.Path & "\aa.jpg")
streamImg.Close
Else
MsgBox "查无图片!", vbInformation + vbOKOnly, "错误!"
End If
RS.Close
Conn.Close
Set Conn = Nothing
End Sub
Private Sub cmdOpen_Click()
Me.CommonDialog1.Filter = "图片(*.jpg;*.gif)|*.jpg;*.gif|所有文件(*.*)|*.*"
Me.CommonDialog1.ShowOpen
txtImgFile.Text = Me.CommonDialog1.FileName
End Sub
Private Sub cmdPut_Click()
strConn = "Driver=SQL Server;Server=.;uid=sa;Pwd=123456;Database=ImgTest"
Conn.ConnectionString = strConn
Conn.CommandTimeout = 10
Conn.Open
strSQL = "Select * from ImgTest"
RS.Open strSQL, Conn, adOpenKeyset, adLockOptimistic
streamImg.Open
streamImg.Type = adTypeBinary
streamImg.LoadFromFile Me.txtImgFile.Text
RS.AddNew
RS("Img") = streamImg.Read
RS.Update
MsgBox "添加图片成功!", vbInformation + vbOKOnly, "添加图片成功!"
streamImg.Close
RS.Close
Conn.Close
Set Conn = Nothing
End Sub
Option Explicit
Private Declare Function CreateStreamOnHGlobal _
Lib "ole32" (ByVal hGlobal As Long, _
ByVal fDeleteOnRelease As Long, _
ppstm As Any) As Long
Private Declare Function OleLoadPicture _
Lib "olepro32" (pStream As Any, _
ByVal lSize As Long, _
ByVal fRunmode As Long, _
riid As Any, _
ppvObj As Any) As Long
Private Declare Function CLSIDFromString _
Lib "ole32" (ByVal lpsz As Any, _
pclsid As Any) As Long
Private Declare Function GlobalAlloc _
Lib "kernel32" (ByVal uFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub MoveMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function