我想把图片和视频保存进这个库中如何炒作
Option ExplicitPrivate Enum MediaTypes
MTGraphic
MTWave
MTAVI
End Enum
Dim rs As Recordset
Dim SQL As String
Dim DataFile As Integer, Fl As Long, Chunks As Integer
Dim Fragment As Integer, Chunk() As Byte, I As Integer
Const ChunkSize As Integer = 16384
Dim NameWanted As String
Dim db As Database
Dim Description As String
Dim lMaxHeight As Long
Dim lMaxWidth As Long
Dim CurMediaType As MediaTypes
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
Const SW_SHOWNORMAL = 1
Private Sub CenterPic()
With picFinal
.Move Shape1.Left + (Shape1.Width - .Width) / 2, Shape1.Top + (Shape1.Height - .Height) / 2
End With
End Sub
Private Sub FixFinalSize()
Dim lTempWidth As Long
Dim lTempHeight As Long
Dim X As Single
Dim Y As Single
lMaxHeight = Shape1.Height - 20
lMaxWidth = Shape1.Width
X = lMaxHeight / Picture1.Height
With picFinal
.Width = Picture1.Width - 10
.Height = Picture1.Height - 10
.Width = .Width * X
.Height = .Height * X
.Top = Shape1.Top
If .Width > lMaxWidth Then
Y = lMaxWidth / .Width
.Width = .Width * Y
.Height = .Height * Y
End If
End With
Me.Refresh
End Sub
Private Sub ReadFromDB()
Dim MediaTemp As String
Dim lngOffset As Long
Dim lngTotalSize As Long
Dim strChunk As String
Dim MediaID As Long
On Error Resume Next
If fa.MouseRow = 0 Then Exit Sub 'only use good rows
MediaID = Val(fa.TextMatrix(fa.MouseRow, 1))
Set rs = db.OpenRecordset("SELECT tblMedia.MediaBLOB, tblMedia.MediaType FROM tblMedia WHERE tblMedia.MediaID = " & MediaID, dbOpenSnapshot)
If rs.RecordCount = 0 Then
MsgBox "error retrieving object"
rs.Close
Set rs = Nothing
Exit Sub
End If
CurMediaType = rs!MediaType
Select Case CurMediaType
Case MTGraphic
MediaTemp = App.Path & "\mdiatemp.tmp"
Case MTWave
MediaTemp = App.Path & "\mdiatemp.wav"
Case MTAVI
MediaTemp = App.Path & "\mdaitemp.avi"
Case Else 'safety
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
DataFile = 1
Open MediaTemp For Binary Access Write As DataFile
If Err.Number = 70 Then
MsgBox Err.Number & vbCr & vbCr & Err.Description & vbCr & vbCr & "this error may be due to " & _
"the media player holding a lock on a wav or avi file." & vbCr & "Close the mediaplayer and try again.", vbInformation, "SMITH MEDIA DEMO"
Err.Clear
rs.Close
Set rs = Nothing
Exit Sub
End If
lngTotalSize = rs!MediaBLOB.FieldSize
Chunks = lngTotalSize \ ChunkSize
Fragment = lngTotalSize Mod ChunkSize
'ReDim Chunk(Fragment)
ReDim Chunk(ChunkSize)
Chunk() = rs!MediaBLOB.GetChunk(lngOffset, ChunkSize)
Put DataFile, , Chunk()
lngOffset = lngOffset + ChunkSize
Do While lngOffset < lngTotalSize
Chunk() = rs!MediaBLOB.GetChunk(lngOffset, ChunkSize)
Put DataFile, , Chunk()
lngOffset = lngOffset + ChunkSize
Loop
Close DataFile
FileName = MediaTemp
End Sub
Private Sub RefillGrid()
Dim sSQL As String
Dim rs As Recordset
Dim lCurRow As Long
sSQL = "SELECT tblMedia.MediaID, tblMedia.MediaName, " & _
"tblMedia.MediaType, tblMedia.MediaDescription FROM " & _
"tblMedia ORDER BY tblMedia.MediaName"
Set rs = db.OpenRecordset(sSQL, dbOpenForwardOnly)
With fa
'setup grid
.Cols = 5
.FixedCols = 1
.ColWidth(1) = 0
.ColWidth(0) = 300
.AllowUserResizing = flexResizeBoth
.Rows = 1
.TextMatrix(0, 2) = "MediaName"
.TextMatrix(0, 3) = "Type"
.TextMatrix(0, 4) = "Description"
'fill grid
Do While Not rs.EOF
lCurRow = .Rows
.Rows = .Rows + 1
.TextMatrix(lCurRow, 1) = CStr(rs!MediaID)
.TextMatrix(lCurRow, 2) = rs!MediaName
.TextMatrix(lCurRow, 3) = rs!MediaType
.TextMatrix(lCurRow, 4) = rs!MediaDescription
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End With
End Sub
Private Sub ResetForm()
'use this in the demo to clear the rest of the form
FileName = ""
txtName = ""
txtDescription = ""
picFinal.Picture = LoadPicture()
picFinal.Visible = False
End Sub
Private Sub ShellPlay(ByVal sPath As String)
Dim lret As Long
Dim sText As String
sText = Trim$(sPath)
lret = ShellExecute(hwnd, "open", sText, vbNull, vbNull, SW_SHOWNORMAL)
If lret >= 0 And lret <= 32 Then
MsgBox "error opening viewer program"
End If
End Sub
Private Sub Command1_Click()
Dim sSQL As String
sSQL = "DELETE * FROM tblMedia"
db.Execute sSQL, dbFailOnError
RefillGrid
End Sub
Private Sub fa_DblClick()
If fa.MouseRow = 0 Then Exit Sub
'quick demo style
ResetForm
ReadFromDB
End Sub
Private Sub FileName_Change()
SaveToDB.Enabled = FileName <> ""
If FileName = "" Then Exit Sub
If CurMediaType = MTGraphic Then
Picture1.Picture = LoadPicture(FileName)
If Picture1.Picture = 0 Then Exit Sub
'figure out how big it should be
picFinal.Visible = False
FixFinalSize
CenterPic
'Now Streach Blt it to picFinal
Dim SourceX As Long, SourceY As Long
SourceX = 0
SourceY = 0
Dim DestX As Long, DestY As Long
DestX = 0
DestY = 0
Dim SourceWidth As Long, SourceHeight As Long
SourceWidth = Picture1.ScaleWidth
SourceHeight = Picture1.ScaleHeight
Dim DestWidth As Long
Dim DestHeight As Long
DestWidth = picFinal.ScaleWidth
DestHeight = picFinal.ScaleHeight
Dim RasterOp As Long
RasterOp = &HCC0020
picFinal.PaintPicture Picture1.Picture, DestX, DestY, DestWidth, DestHeight, 0, 0, SourceWidth, SourceHeight, RasterOp&
picFinal.Visible = True
Else
'call media player or whatever default viewer the user has
ShellPlay FileName
End If
End Sub
Private Sub Form_Load()
Set db = Workspaces(0).OpenDatabase(App.Path & "\grx.mdb")
ResetForm
RefillGrid
End Sub
Private Sub SaveToDB_Click()
Dim MediaName As String
MediaName = Trim$(txtName)
If Len(MediaName) = 0 Then
MsgBox "请输入媒体文件的名称！"
Exit Sub
End If
Set rs = db.OpenRecordset("SELECT * FROM tblMedia WHERE tblMedia.MediaName = " & Chr(34) & MediaName & Chr(34), dbOpenDynaset)
If rs Is Nothing Or rs.Updatable = False Then
MsgBox "不能打开或写入记录集！"
Exit Sub
End If
If rs.EOF Then
rs.AddNew
Else
rs.Edit
End If
rs!MediaName = MediaName
Description = Trim$(txtDescription)
rs!MediaDescription = Description
rs!MediaType = CurMediaType
DataFile = 1
Open FileName For Binary Access Read As DataFile
Fl = LOF(DataFile) ' 文件中数据长度
If Fl = 0 Then
Close DataFile
Exit Sub
End If
Chunks = Fl \ ChunkSize
Fragment = Fl Mod ChunkSize
'Rs!Pic.AppendChunk Null
ReDim Chunk(Fragment)
Get DataFile, , Chunk()
rs!MediaBLOB.AppendChunk Chunk()
ReDim Chunk(ChunkSize)
For I = 1 To Chunks
Get DataFile, , Chunk()
rs!MediaBLOB.AppendChunk Chunk()
Next I
Close DataFile
rs.Update
rs.Close
Set rs = Nothing
ResetForm
RefillGrid
End Sub
Private Sub LoadFromFile_Click() '
'定位媒体文件并将值赋给变量FileName
On Error Resume Next
With CommonDialog1
.CancelError = True
.Filter = "Pictures(*.bmp;*.ico;*.gif;*.jpg)|*.bmp;*.ico;*.gif;*.jpg|" & _
"Wave Files(*.wav)|*.wav|MS Video(*.avi)|*.avi"
.Flags = cdlOFNHideReadOnly
.ShowOpen
If Err.Number = cdlCancel Then
Err.Clear
Exit Sub
End If
CurMediaType = .FilterIndex - 1
FileName = .FileName
End With
End Sub
d015_chunkole.zip