Option Explicit
Private 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

急需 谢谢了 有会的大神吗

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

这个地方有问题该怎么修改

Set db = Workspaces(0).OpenDatabase("C:\Documents and Settings\Administrator" & "\grx.mdb") 有错误该怎么改？？？

你可以帮我调试一下么？？急用

我想把图片和视频插入其中  你可以帮我调试一下么？？

你能教我怎么插进去的图么  我看我的操作是不是错了

是这个错误

这个是什么错误