Public ImgPath As String
Public Function LoadBImage(ByVal NewForm As Form,
_
ByVal NewID As String, _
ByVal NewIDValue As Variant, _
ByVal
NewField As String, _
ByVal NewImage As
Image)
'===============================================================================
'-函数名称:
LoadBImage
'-功能描述: 以二进制数据格式加载图片,并保存于数据库,一般为当前数据库,
'
若窗体引用记录集为外部ACCESS数据库,同样适用,调用函数SaveImage
'-输入参数说明: 参数1: 必选
应用显示图片的窗体,[对象变量]
' 参数2: 必选 窗体记录集的主键名,[文本变量]
'
参数3: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
' 参数4: 必选
图片所在的字段名,[文本变量]
' 参数5: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明:
无
'-使用语法示例: Call LoadBImage(Me, "id", me.id, "图片",
me.image1)
'-参考:
'-使用注意: NewForm, NewImage 为对象，使用时不能加引号
'
因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:
2000,XP,2003 compatible
'-作者: duomu
'-更新日期：
2007-09-6
'===============================================================================
Dim result As Integer
Dim FileName As String
On Error GoTo
HandleErr
If Len(ImgPath) = 0 Then ImgPath = CurrentProject.Path
With Application.FileDialog(1)
.Title = "选择照片"
.Filters.Clear
.Filters.Add "所有文件", "*.*"
.Filters.Add
"JPEGs", "*.jpg"
.Filters.Add "位图文件", "*.bmp"
.FilterIndex
= 2
.AllowMultiSelect = False
.InitialFileName =
ImgPath
result = .Show
If result = -1 Then
FileName = Trim(.SelectedItems.Item(1))
Call
SaveBImage(FileName, NewForm, NewID, NewIDValue, NewField, NewImage)
Else
LoadBImage = 1
Exit Function
End If
ImgPath = FileName
NewImage.Picture =
FileName
End With
ExitHere:
Exit Function
HandleErr:
MsgBox Err.Description
Resume ExitHere
End Function
Public Function
SaveBImage(ByVal FileName As String, _
ByVal
NewForm As Form, _
ByVal NewID As String, _
ByVal NewIDValue As Variant, _
ByVal NewField As String, _
ByVal NewImage
As
Image)
'===============================================================================
'-函数名称:
SaveBImage
'-功能描述: 以二进制数据格式加载图片,并保存于数据库,一般为当前数据库,
'
若窗体引用记录集为外部ACCESS数据库,同样适用,调用函数SaveImage
'-输入参数说明: 参数1: 必选 图片路径,[文本变量]
'
参数2: 必选 应用显示图片的窗体,[对象变量]
' 参数3: 必选
窗体记录集的主键名,[文本变量]
' 参数4: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
'
参数5: 必选 图片所在的字段名,[文本变量]
' 参数6: 必选
应用显示的图片控件,[对象变量]
'-返回参数说明: 无
'-使用语法示例: 略
'-参考:
LoadBImage()过程
'-使用注意: NewForm, NewImage 为对象，使用时不能加引号
'
因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性: 2000,XP,2003
compatible
'-作者: duomu
'-更新日期：
2007-09-6
'===============================================================================
Dim ObjRst As DAO.Recordset
Dim ObjStream As ADODB.Stream
On
Error GoTo HandleErr
Set ObjRst = NewForm.Recordset
Set ObjStream
= New ADODB.Stream
If Not IsNull(FileName) Then
With
ObjStream
.Type = adTypeBinary
.Open
.LoadFromFile FileName
End With
End If
If
ObjRst.Fields(NewID).Type = dbText Then
ObjRst.FindFirst "[" &
NewID & "]" & " = '" & NewIDValue & "'"
Else
ObjRst.FindFirst "[" & NewID & "]" & " = " & NewIDValue
End If
If Not ObjRst.NoMatch Then
ObjRst.Edit
ObjRst(NewField) = ObjStream.Read
ObjRst.Update
End If
ObjStream.Close
Set ObjStream = Nothing
ExitHere:
Exit
Function
HandleErr:
MsgBox Err.Description
Resume
ExitHere
End Function
Public Function DisplayBImage(ByVal NewForm As Form,
_
ByVal NewID As String, _
ByVal NewIDValue As Variant, _
ByVal NewField As String, _
ByVal NewImage As
Image)
'===============================================================================
'-函数名称:
DisplayBImage
'-功能描述: 显示以二进制数据格式保存在数据库内的图片
'-输入参数说明: 参数1: 必选
应用显示图片的窗体,[对象变量]
' 参数2: 必选 窗体记录集的主键名,[文本变量]
'
参数3: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
' 参数4: 必选
图片所在的字段名,[文本变量]
' 参数5: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明:
无
'-使用语法示例: Call DisplayBImage(Me, "id", me.id, "图片",
me.image1)
'-参考:
'-使用注意: NewForm, NewImage 为对象，使用时不能加引号
'
因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:
2000,XP,2003 compatible
'-作者: duomu
'-更新日期：
2007-09-6
'===============================================================================
Dim ObjRst As DAO.Recordset
Dim ObjStream As ADODB.Stream
On
Error GoTo HandleErr
Set ObjRst = NewForm.Recordset
Set ObjStream
= New ADODB.Stream
If IsNull(NewIDValue) Then NewImage.Picture = "": Exit
Function
If ObjRst.Fields(NewID).Type = dbText Then
ObjRst.FindFirst "[" & NewID & "]" & " = '" & NewIDValue
& "'"
Else
ObjRst.FindFirst "[" & NewID & "]"
& " = " & NewIDValue
End If
If Not ObjRst.NoMatch
Then
If Len(ObjRst(NewField)) > 0 Then
With
ObjStream
.Mode = adModeReadWrite
.Type =
adTypeBinary
.Open
.Write
ObjRst(NewField)
.SaveToFile CurrentProject.Path &
"\image.jpg", adSaveCreateOverWrite
End With
Else
NewImage.Picture = ""
Exit Function
End
If
End If
NewImage.Picture = CurrentProject.Path &
"\image.jpg"
NewImage.SizeMode = acOLESizeZoom
ObjStream.Close
Kill CurrentProject.Path & "\image.jpg"
Set
ObjStream = Nothing
ExitHere:
Exit Function
HandleErr:
MsgBox Err.Description
Resume ExitHere
End Function
Public Function
DeleteBImage(ByVal NewForm As Form, _
ByVal
NewID As String, _
ByVal NewIDValue As Variant,
_
ByVal NewField As String, _
ByVal NewImage As
Image)
'===============================================================================
'-函数名称:
LoadImage
'-功能描述: 删除以二进制数据格式保存在数据库内的图片
'-输入参数说明: 参数1: 必选
应用显示图片的窗体,[对象变量]
' 参数2: 必选 窗体记录集的主键名,[文本变量]
'
参数3: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
' 参数4: 必选
图片所在的字段名,[文本变量]
' 参数5: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明:
无
'-使用语法示例: Call LoadImage(Me, "id", me.id, "图片",
me.image1)
'-参考:
'-使用注意: NewForm, NewImage 为对象，使用时不能加引号
'
因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:
2000,XP,2003 compatible
'-作者: duomu
'-更新日期：
2007-09-6
'===============================================================================
Dim ObjRst As DAO.Recordset
On Error GoTo HandleErr
Set ObjRst =
NewForm.Recordset
If ObjRst.Fields(NewID).Type = dbText Then
ObjRst.FindFirst "[" & NewID & "]" & " = '" & NewIDValue
& "'"
Else
ObjRst.FindFirst "[" & NewID & "]"
& " = " & NewIDValue
End If
If Not ObjRst.NoMatch
Then
ObjRst.Edit
ObjRst(NewField) = ""
ObjRst.Update
End If
NewImage.Picture = ""
ExitHere:
Exit Function
HandleErr:
MsgBox Err.Description
Resume
ExitHere
End Function
