frmmain.frm

将多媒体文件保存到数据库中

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmMain 
   BackColor       =   &H00C0FFFF&
   Caption         =   "Form1"
   ClientHeight    =   6240
   ClientLeft      =   -210
   ClientTop       =   825
   ClientWidth     =   9585
   LinkTopic       =   "Form1"
   ScaleHeight     =   6240
   ScaleWidth      =   9585
   Begin VB.CommandButton Command1 
      Caption         =   "清空数据库"
      Height          =   330
      Left            =   1260
      TabIndex        =   10
      Top             =   5040
      Width           =   1380
   End
   Begin VB.TextBox txtDescription 
      Height          =   645
      Left            =   2625
      MultiLine       =   -1  'True
      TabIndex        =   7
      Top             =   1155
      Width           =   5160
   End
   Begin VB.TextBox txtName 
      Height          =   330
      Left            =   2625
      TabIndex        =   6
      Top             =   735
      Width           =   2325
   End
   Begin MSFlexGridLib.MSFlexGrid fa 
      Height          =   2325
      Left            =   0
      TabIndex        =   4
      Top             =   2625
      Width           =   4005
      _ExtentX        =   7064
      _ExtentY        =   4101
      _Version        =   393216
      WordWrap        =   -1  'True
   End
   Begin VB.PictureBox picFinal 
      AutoRedraw      =   -1  'True
      Height          =   2010
      Left            =   5250
      ScaleHeight     =   1950
      ScaleWidth      =   2580
      TabIndex        =   3
      Top             =   3360
      Visible         =   0   'False
      Width           =   2640
   End
   Begin VB.CommandButton SaveToDB 
      Caption         =   "保存到数据库"
      Height          =   330
      Left            =   315
      TabIndex        =   2
      Top             =   735
      Width           =   1695
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   7980
      Top             =   210
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton LoadFromFile 
      Caption         =   "定位文件"
      Height          =   330
      Left            =   315
      TabIndex        =   1
      Top             =   120
      Width           =   1695
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      Height          =   435
      Left            =   8400
      ScaleHeight     =   375
      ScaleWidth      =   480
      TabIndex        =   0
      Top             =   210
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0FFFF&
      Caption         =   "双击其中的一行以查看或播放媒体文件："
      Height          =   180
      Left            =   105
      TabIndex        =   9
      Top             =   2280
      Width           =   3240
   End
   Begin VB.Label Label1 
      BackColor       =   &H00C0FFFF&
      Caption         =   "图片大小取决于控件Shape1的大小，但图片仍会保持其原始比例。试试改变控件Shape1的大小和形状，看看效果如何。"
      Height          =   675
      Left            =   4725
      TabIndex        =   8
      Top             =   2205
      Width           =   3600
   End
   Begin VB.Label FileName 
      BorderStyle     =   1  'Fixed Single
      Height          =   330
      Left            =   2625
      TabIndex        =   5
      Top             =   105
      Width           =   5265
   End
   Begin VB.Shape Shape1 
      Height          =   4110
      Left            =   4095
      Top             =   1995
      Width           =   5265
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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