www.pudn.com > 将图片添加到Access数据库中.zip > MAIN.FRM
VERSION 4.00
Begin VB.Form frmMain
AutoRedraw = -1 'True
BorderStyle = 3 'Fixed Dialog
Caption = "Q&A Database Picture Editor"
ClientHeight = 5340
ClientLeft = 1755
ClientTop = 975
ClientWidth = 6045
ClipControls = 0 'False
Height = 5745
Left = 1695
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5340
ScaleWidth = 6045
ShowInTaskbar = 0 'False
Top = 630
Width = 6165
Begin VB.CommandButton cmdBrowse
Caption = "..."
Enabled = 0 'False
BeginProperty Font
name = "Arial"
charset = 0
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 260
Index = 1
Left = 4230
TabIndex = 7
TabStop = 0 'False
Top = 1590
Width = 260
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "Cancel"
Enabled = 0 'False
Height = 375
Left = 4680
TabIndex = 9
Top = 805
Width = 1200
End
Begin VB.CommandButton cmdBrowse
Caption = "..."
BeginProperty Font
name = "Arial"
charset = 0
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 260
Index = 0
Left = 4230
TabIndex = 2
TabStop = 0 'False
Top = 390
Width = 260
End
Begin VB.CommandButton cmdNew
Caption = "&New Record"
Enabled = 0 'False
Height = 375
Left = 4680
TabIndex = 8
Top = 360
Width = 1200
End
Begin VB.Data datCtl
Connect = ""
DatabaseName = ""
Exclusive = 0 'False
Height = 300
Left = 120
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 4920
Width = 4395
End
Begin VB.ComboBox cboField
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 4
Top = 960
Width = 4395
End
Begin VB.TextBox txtDBName
Height = 315
Left = 120
TabIndex = 1
Top = 360
Width = 4395
End
Begin VB.TextBox txtPicFile
BackColor = &H8000000F&
Enabled = 0 'False
Height = 315
Left = 120
TabIndex = 6
Top = 1560
Width = 4395
End
Begin VB.Label lblPicture
AutoSize = -1 'True
Caption = "Picture &File:"
Height = 195
Left = 120
TabIndex = 5
Top = 1320
Width = 825
End
Begin VB.Image imgPreview
BorderStyle = 1 'Fixed Single
DataSource = "datCtl"
Height = 2895
Left = 120
Stretch = -1 'True
Top = 1950
Width = 4395
End
Begin VB.Label lblField
AutoSize = -1 'True
Caption = "&Picture Field:"
Height = 195
Left = 120
TabIndex = 3
Top = 720
Width = 915
End
Begin VB.Label lblDBName
AutoSize = -1 'True
Caption = "&Database Name:"
Height = 195
Left = 120
TabIndex = 0
Top = 120
Width = 1200
End
End
Attribute VB_Name = "frmMain"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Private Const vbDBName As Byte = 1
Private Const vbPicture As Byte = 2
Private bDirty(1 To 2) As Boolean
Private Sub cboField_Click()
Dim iPeriod As Integer
Dim sField As String
Dim sTable As String
iPeriod = InStr(cboField, ".")
If iPeriod Then
' Separate combo box item into table
' and field names; remove brackets
sTable = Left$(cboField, iPeriod - 1)
If Left$(sTable, 1) = "[" Then
sTable = Mid$(sTable, 2, Len(sTable) - 2)
End If
sField = Mid$(cboField, iPeriod + 1)
If Left$(sField, 1) = "[" Then
sField = Mid$(sField, 2, Len(sField) - 2)
End If
' Assign data control's RecordSource
' to selected table; bind image control
' to selected field
datCtl.RecordSource = sTable
imgPreview.DataField = sField
cmdNew.Enabled = True
cmdCancel.Enabled = True
datCtl.Refresh
End If
End Sub
Private Sub cmdBrowse_Click(Index As Integer)
' Display OpenFile dialog and allow user to
' select database or picture file
Dim sFilter As String
OpenFileDlg.hWndOwner = Me.hWnd
Select Case Index
Case 0
txtDBName.SetFocus
OpenFileDlg.Title = "Select Database"
sFilter = "Microsoft Access Databases" & vbNullChar & "*.MDB" & vbNullChar
sFilter = sFilter & "All Files" & vbNullChar & "*.*" & String$(2, 0)
OpenFileDlg.Filter = sFilter
OpenFileDlg.FileName = ""
OpenFileDlg.Show
If Len(OpenFileDlg.FileName) Then
txtDBName = OpenFileDlg.FileName
Call DBOpen
End If
Case 1
txtPicFile.SetFocus
OpenFileDlg.Title = "Select Picture"
sFilter = "Picture Files" & vbNullChar & "*.BMP;*.ICO;*.RLE;*.WMF" & vbNullChar
sFilter = sFilter & "All Files" & vbNullChar & "*.*" & String$(2, 0)
OpenFileDlg.Filter = sFilter
OpenFileDlg.FileName = ""
OpenFileDlg.Show
If Len(OpenFileDlg.FileName) Then
txtPicFile = OpenFileDlg.FileName
imgPreview.Picture = LoadPicture(txtPicFile)
bDirty(vbPicture) = False
End If
End Select
End Sub
Private Sub PopulateCombo(db As Database)
' Populates cboField with names of Long Binary
' fields (and the tables containing them) in the
' current database.
Dim fld As Field
Dim tbl As TableDef
Dim sField As String
Dim sTable As String
Const vbSpace As String = " "
cboField.Clear
For Each tbl In db.TableDefs
sTable = tbl.Name
If Left$(sTable, 4) <> "MSys" Then
For Each fld In tbl.Fields
If fld.Type = dbLongBinary Then
sField = fld.Name
If InStr(sField, vbSpace) Then
sField = "[" & sField & "]"
End If
If InStr(sTable, vbSpace) Then
sTable = "[" & sTable & "]"
End If
cboField.AddItem sTable & "." & sField
End If
Next
End If
Next
End Sub
Private Sub cmdCancel_Click()
txtPicFile = ""
bDirty(vbPicture) = False
cmdNew.Caption = "&New Record"
If datCtl.Recordset.RecordCount = 0 Then
datCtl.Caption = ""
Call DisablePicField
Else
datCtl.Recordset.MoveFirst
datCtl.UpdateControls
End If
End Sub
Private Sub cmdNew_Click()
If cmdNew.Caption = "&Update" Then
datCtl.Recordset.Update
datCtl.Recordset.Bookmark = datCtl.Recordset.LastModified
Else
datCtl.Recordset.AddNew
If txtPicFile.Enabled = False Then
Call EnablePicField
End If
datCtl.Caption = "[New Record]"
cmdNew.Caption = "&Update"
End If
End Sub
Private Sub datCtl_Error(DataErr As Integer, Response As Integer)
' Invalid Picture
If DataErr = 481 Then
Response = vbDataErrContinue
End If
End Sub
Private Sub datCtl_Reposition()
Dim lRec As Long
lRec = datCtl.Recordset.AbsolutePosition
If lRec >= 0 Then
datCtl.Caption = "Record " & CStr(lRec + 1)
If txtPicFile.Enabled = False Then
Call EnablePicField
End If
End If
End Sub
Sub DBOpen()
If Len(txtDBName) Then
Me.MousePointer = vbHourglass
If Not (datCtl.Database Is Nothing) Then
datCtl.Caption = ""
datCtl.Database.Close
txtPicFile = ""
bDirty(vbPicture) = False
Call DisablePicField
imgPreview.Picture = LoadPicture()
cmdNew.Caption = "&New Record"
cmdNew.Enabled = False
End If
datCtl.DatabaseName = txtDBName
datCtl.RecordSource = ""
datCtl.Refresh
Call PopulateCombo(datCtl.Database)
Me.MousePointer = vbDefault
End If
bDirty(vbDBName) = False
End Sub
Private Sub datCtl_Validate(Action As Integer, Save As Integer)
cmdNew.Caption = "&New Record"
txtPicFile = ""
bDirty(vbPicture) = False
End Sub
Private Sub txtDBName_Change()
bDirty(vbDBName) = True
End Sub
Private Sub txtDBName_LostFocus()
If bDirty(vbDBName) Then
Call DBOpen
End If
End Sub
Private Sub txtPicFile_Change()
If Len(txtPicFile) Then
bDirty(vbPicture) = True
If datCtl.Recordset.EditMode = dbEditNone Then
datCtl.Recordset.Edit
cmdNew.Caption = "&Update"
End If
End If
End Sub
Private Sub txtPicFile_LostFocus()
If Len(txtPicFile) Then
If bDirty(vbPicture) Then
imgPreview.Picture = LoadPicture(txtPicFile)
bDirty(vbPicture) = False
End If
End If
End Sub
Sub DisablePicField()
With txtPicFile
.Enabled = False
.BackColor = vbButtonFace
End With
cmdBrowse(1).Enabled = False
End Sub
Sub EnablePicField()
With txtPicFile
.Enabled = True
.BackColor = vbWindowBackground
.Text = ""
End With
cmdBrowse(1).Enabled = True
bDirty(vbPicture) = False
End Sub