1,216
社区成员
发帖
与我相关
我的任务
分享谁来帮我注释段代码，谢谢 急！在线等待
功能是实现在数据库中添加多媒体文件
在窗体中用到的主要控件有commandbutton控件、textbox控件、CommonDialog控件MSFLEXGRID控件。其中commandbutton控件有6个其名称和功用分别为LoadFromFile（打开文件）、SaveToDB（保存）、Command1（清空记录）、Command2（删除）Command3（查询）、Command5（退出）。两个文本框被命名为txtName（存储名称）、txtDescription（说明描述）。MSFLEXGRID控件名称为FA，主要是显示数据库中的记录。，请帮我详细注释下，还有如何实现删除某一记录和以文件名查询的功能。谢谢，请详细说明，我会结贴补加100分
在窗体中用到的主要控件有commandbutton控件、textbox控件、CommonDialog控件MSFLEXGRID控件。其中commandbutton控件有6个其名称和功用分别为LoadFromFile（打开文件）、SaveToDB（保存）、Command1（清空记录）、Command2（删除）Command3（查询）、Command5（退出）。两个文本框被命名为txtName（存储名称）、txtDescription（说明描述）。MSFLEXGRID控件名称为FA，主要是显示数据库中的记录。，请帮我详细注释下，还有如何实现删除某一记录和以文件名查询的功能。谢谢，请详细说明，我会结贴补加100分
...全文
请发表友善的回复…
发表回复
sleilei 2003-09-23
- 打赏
- 举报
上面是代码，大家帮我注释下，和实现删除某一记录和以文件名查询的功能一定给分,
数据库grx.mdb中只有一个表tblMedia,结构如下:
字段名 字段类型 字段长度
MediaID LONG 4
MediaBLOB BINARY
MediaName TEXT 50
MediaDescription MEMO
MediaType Integer 2
数据库grx.mdb中只有一个表tblMedia,结构如下:
字段名 字段类型 字段长度
MediaID LONG 4
MediaBLOB BINARY
MediaName TEXT 50
MediaDescription MEMO
MediaType Integer 2
sleilei 2003-09-23
- 打赏
- 举报
Option Explicit
Private Enum MediaTypes
MTGraphic
MTWave
MTAVI
MTMP3
End Enum
Dim rs As Recordset
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 filename As String
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 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
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 MTMP3
MediaTemp = App.Path & "\mdaitemp.mp3"
Case Else
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
Kill (MediaTemp)
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(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
ShellPlay 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()
txtName = ""
txtDescription = ""
Label3.Caption = ""
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_Click()
Dim mediaid As Long
If fa.MouseRow = 1 Then Exit Sub
mediaid = Val(fa.TextMatrix(fa.MouseRow, 1))
did = mediaid
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
picFinal.Visible = False
FixFinalSize
CenterPic
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
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
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() '
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|all files(*.*)|*.*"
.Flags = cdlOFNHideReadOnly
.ShowOpen
If Err.Number = cdlCancel Then
Err.Clear
Exit Sub
End If
CurMediaType = .FilterIndex - 1
Label3.Caption = .filename
filename = .filename
txtName.Text = .FileTitle
End With
End Sub
Private Enum MediaTypes
MTGraphic
MTWave
MTAVI
MTMP3
End Enum
Dim rs As Recordset
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 filename As String
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 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
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 MTMP3
MediaTemp = App.Path & "\mdaitemp.mp3"
Case Else
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
Kill (MediaTemp)
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(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
ShellPlay 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()
txtName = ""
txtDescription = ""
Label3.Caption = ""
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_Click()
Dim mediaid As Long
If fa.MouseRow = 1 Then Exit Sub
mediaid = Val(fa.TextMatrix(fa.MouseRow, 1))
did = mediaid
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
picFinal.Visible = False
FixFinalSize
CenterPic
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
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
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() '
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|all files(*.*)|*.*"
.Flags = cdlOFNHideReadOnly
.ShowOpen
If Err.Number = cdlCancel Then
Err.Clear
Exit Sub
End If
CurMediaType = .FilterIndex - 1
Label3.Caption = .filename
filename = .filename
txtName.Text = .FileTitle
End With
End Sub
zhangying7725 2003-09-23
- 打赏
- 举报
鼓掌，小马哥，厉害！真的有工夫！
yoki 2003-09-23
- 打赏
- 举报
Private Sub FileName_Change()
SaveToDB.Enabled = filename <> ""
If filename = "" Then Exit Sub
If CurMediaType = MTGraphic Then
'如果打开的纪录存的是图像，那么在Picture控件中显示对应图像
Picture1.Picture = LoadPicture(filename)
If Picture1.Picture = 0 Then Exit Sub
picFinal.Visible = False
FixFinalSize
CenterPic
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
'否则，调用相关程序打开文件
ShellPlay filename
End If
End Sub
Private Sub Form_Load()
'打开文件grx.mdb，并初始化网格与提示信息
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
'读取文件到对应字段rs!MediaBLOB
Fl = LOF(DataFile) ' 文件中数据长度
If Fl = 0 Then
Close DataFile
Exit Sub
End If
Chunks = Fl \ ChunkSize
Fragment = Fl Mod ChunkSize
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() '
'选择文件，得到要打开的文件名
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|all files(*.*)|*.*"
.Flags = cdlOFNHideReadOnly
.ShowOpen
If Err.Number = cdlCancel Then
Err.Clear
Exit Sub
End If
CurMediaType = .FilterIndex - 1
Label3.Caption = .filename
filename = .filename
txtName.Text = .FileTitle
End With
End Sub
SaveToDB.Enabled = filename <> ""
If filename = "" Then Exit Sub
If CurMediaType = MTGraphic Then
'如果打开的纪录存的是图像，那么在Picture控件中显示对应图像
Picture1.Picture = LoadPicture(filename)
If Picture1.Picture = 0 Then Exit Sub
picFinal.Visible = False
FixFinalSize
CenterPic
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
'否则，调用相关程序打开文件
ShellPlay filename
End If
End Sub
Private Sub Form_Load()
'打开文件grx.mdb，并初始化网格与提示信息
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
'读取文件到对应字段rs!MediaBLOB
Fl = LOF(DataFile) ' 文件中数据长度
If Fl = 0 Then
Close DataFile
Exit Sub
End If
Chunks = Fl \ ChunkSize
Fragment = Fl Mod ChunkSize
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() '
'选择文件，得到要打开的文件名
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|all files(*.*)|*.*"
.Flags = cdlOFNHideReadOnly
.ShowOpen
If Err.Number = cdlCancel Then
Err.Clear
Exit Sub
End If
CurMediaType = .FilterIndex - 1
Label3.Caption = .filename
filename = .filename
txtName.Text = .FileTitle
End With
End Sub
yoki 2003-09-23
- 打赏
- 举报
'++++++++++++++++++++
'********************
Option Explicit
Private Enum MediaTypes '枚举各媒体文件类型
MTGraphic
MTWave
MTAVI
MTMP3
End Enum
Dim rs As Recordset '记录集,用于存放打开的纪录
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 filename As String
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 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
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 MTMP3
MediaTemp = App.path & "\mdaitemp.mp3"
Case Else
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
Kill (MediaTemp)
'若已经存在对应的媒体文件，则删除
DataFile = 1
Open MediaTemp For Binary Access Write As DataFile
'打开对应的媒体文件(MediaTemp)往里写
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(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
ShellPlay 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()
'清空各提示
txtName = ""
txtDescription = ""
Label3.Caption = ""
End Sub
Private Sub ShellPlay(ByVal sPath As String)
'调用API函数ShellExecute打开对应的文件
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" '你这没加条件where...，应该是删除所有的纪录
db.Execute sSQL, dbFailOnError
RefillGrid
End Sub
Private Sub fa_Click()
'得到选中纪录的ID值，用于标志选中的纪录
Dim mediaid As Long
If fa.MouseRow = 1 Then Exit Sub
mediaid = Val(fa.TextMatrix(fa.MouseRow, 1))
did = mediaid
End Sub
Private Sub fa_DblClick()
'双击时先清空个提示信息，然后打开选中的文件
If fa.MouseRow = 0 Then Exit Sub
'quick demo style
ResetForm
ReadFromDB
End Sub
'********************
Option Explicit
Private Enum MediaTypes '枚举各媒体文件类型
MTGraphic
MTWave
MTAVI
MTMP3
End Enum
Dim rs As Recordset '记录集,用于存放打开的纪录
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 filename As String
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 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
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 MTMP3
MediaTemp = App.path & "\mdaitemp.mp3"
Case Else
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
Kill (MediaTemp)
'若已经存在对应的媒体文件，则删除
DataFile = 1
Open MediaTemp For Binary Access Write As DataFile
'打开对应的媒体文件(MediaTemp)往里写
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(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
ShellPlay 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()
'清空各提示
txtName = ""
txtDescription = ""
Label3.Caption = ""
End Sub
Private Sub ShellPlay(ByVal sPath As String)
'调用API函数ShellExecute打开对应的文件
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" '你这没加条件where...，应该是删除所有的纪录
db.Execute sSQL, dbFailOnError
RefillGrid
End Sub
Private Sub fa_Click()
'得到选中纪录的ID值，用于标志选中的纪录
Dim mediaid As Long
If fa.MouseRow = 1 Then Exit Sub
mediaid = Val(fa.TextMatrix(fa.MouseRow, 1))
did = mediaid
End Sub
Private Sub fa_DblClick()
'双击时先清空个提示信息，然后打开选中的文件
If fa.MouseRow = 0 Then Exit Sub
'quick demo style
ResetForm
ReadFromDB
End Sub
yoki 2003-09-23
- 打赏
- 举报
'++++++++++++++++++++
'********************
Option Explicit
Private Enum MediaTypes '枚举各媒体文件类型
MTGraphic
MTWave
MTAVI
MTMP3
End Enum
Dim rs As Recordset '记录集,用于存放打开的纪录
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 filename As String
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 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
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 MTMP3
MediaTemp = App.path & "\mdaitemp.mp3"
Case Else
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
Kill (MediaTemp)
'若已经存在对应的媒体文件，则删除
DataFile = 1
Open MediaTemp For Binary Access Write As DataFile
'打开对应的媒体文件(MediaTemp)往里写
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(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
ShellPlay 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()
'清空各提示
txtName = ""
txtDescription = ""
Label3.Caption = ""
End Sub
Private Sub ShellPlay(ByVal sPath As String)
'调用API函数ShellExecute打开对应的文件
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" '你这没加条件where...，应该是删除所有的纪录
db.Execute sSQL, dbFailOnError
RefillGrid
End Sub
Private Sub fa_Click()
'得到选中纪录的ID值，用于标志选中的纪录
Dim mediaid As Long
If fa.MouseRow = 1 Then Exit Sub
mediaid = Val(fa.TextMatrix(fa.MouseRow, 1))
did = mediaid
End Sub
Private Sub fa_DblClick()
'双击时先清空个提示信息，然后打开选中的文件
If fa.MouseRow = 0 Then Exit Sub
'quick demo style
ResetForm
ReadFromDB
End Sub
'********************
Option Explicit
Private Enum MediaTypes '枚举各媒体文件类型
MTGraphic
MTWave
MTAVI
MTMP3
End Enum
Dim rs As Recordset '记录集,用于存放打开的纪录
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 filename As String
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 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
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 MTMP3
MediaTemp = App.path & "\mdaitemp.mp3"
Case Else
rs.Close
Set rs = Nothing
MsgBox "Error retrieving object"
Exit Sub
End Select
Kill (MediaTemp)
'若已经存在对应的媒体文件，则删除
DataFile = 1
Open MediaTemp For Binary Access Write As DataFile
'打开对应的媒体文件(MediaTemp)往里写
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(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
ShellPlay 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()
'清空各提示
txtName = ""
txtDescription = ""
Label3.Caption = ""
End Sub
Private Sub ShellPlay(ByVal sPath As String)
'调用API函数ShellExecute打开对应的文件
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" '你这没加条件where...，应该是删除所有的纪录
db.Execute sSQL, dbFailOnError
RefillGrid
End Sub
Private Sub fa_Click()
'得到选中纪录的ID值，用于标志选中的纪录
Dim mediaid As Long
If fa.MouseRow = 1 Then Exit Sub
mediaid = Val(fa.TextMatrix(fa.MouseRow, 1))
did = mediaid
End Sub
Private Sub fa_DblClick()
'双击时先清空个提示信息，然后打开选中的文件
If fa.MouseRow = 0 Then Exit Sub
'quick demo style
ResetForm
ReadFromDB
End Sub
