一个例子:
openfile.bas
Attribute VB_Name = "OpenFileDlg"
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCusFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private OFN As OPENFILENAME
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (lpOFN As OPENFILENAME) As Long
Private Declare Function VarPtr Lib "VB40032.DLL" (lpVar As Any) As LongPublic hWndOwner As Long
Public FileName As String
Public Filter As String
Public Title As StringSub Show() Dim iNull As Integer
Dim sFilter As String
Dim sNull As String
Dim sTitle As String
Dim sFileName As String * 1024
LSet sFileName = FileName & vbNullChar
With OFN
.lStructSize = Len(OFN)
.hWndOwner = hWndOwner
.lpstrFilter = Filter
.lpstrFile = sFileName
.nMaxFile = Len(sFileName)
.lpstrTitle = Title
.Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
End With If GetOpenFileName(OFN) Then
iNull = InStr(OFN.lpstrFile, vbNullChar)
If iNull Then
FileName = Left$(OFN.lpstrFile, iNull - 1)
Else
FileName = OFN.lpstrFile
End If
Else
FileName = ""
End IfEnd Sub
下面还有:
openfile.bas
Attribute VB_Name = "OpenFileDlg"
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCusFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private OFN As OPENFILENAME
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (lpOFN As OPENFILENAME) As Long
Private Declare Function VarPtr Lib "VB40032.DLL" (lpVar As Any) As LongPublic hWndOwner As Long
Public FileName As String
Public Filter As String
Public Title As StringSub Show() Dim iNull As Integer
Dim sFilter As String
Dim sNull As String
Dim sTitle As String
Dim sFileName As String * 1024
LSet sFileName = FileName & vbNullChar
With OFN
.lStructSize = Len(OFN)
.hWndOwner = hWndOwner
.lpstrFilter = Filter
.lpstrFile = sFileName
.nMaxFile = Len(sFileName)
.lpstrTitle = Title
.Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
End With If GetOpenFileName(OFN) Then
iNull = InStr(OFN.lpstrFile, vbNullChar)
If iNull Then
FileName = Left$(OFN.lpstrFile, iNull - 1)
Else
FileName = OFN.lpstrFile
End If
Else
FileName = ""
End IfEnd Sub
下面还有:
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 BooleanPrivate 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 IfEnd Sub
Private Sub cmdBrowse_Click(Index As Integer) ' Display OpenFile dialog and allow user to
' select database or picture file 还有
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 SelectEnd 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
NextEnd 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 IfEnd Sub
Private Sub cmdNew_Click() If cmdNew.Caption = "&Update" Then
datCtl.Recordset.Update
datCtl.Recordset.Book = datCtl.Recordset.LastModified
Else
datCtl.Recordset.AddNew
If txtPicFile.Enabled = False Then
Call EnablePicField
End If
datCtl.Caption = "[New Record]"
cmdNew.Caption = "&Update"
End IfEnd Sub
Private Sub datCtl_Error(DataErr As Integer, Response As Integer) ' Invalid Picture
If DataErr = 481 Then
Response = vbDataErrContinue
End IfEnd 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 IfEnd 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) = FalseEnd Sub
Private Sub datCtl_Validate(Action As Integer, Save As Integer) cmdNew.Caption = "&New Record"
txtPicFile = ""
bDirty(vbPicture) = FalseEnd Sub
Private Sub txtDBName_Change() bDirty(vbDBName) = TrueEnd Sub
Private Sub txtDBName_LostFocus() If bDirty(vbDBName) Then
Call DBOpen
End IfEnd 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 IfEnd Sub
Private Sub txtPicFile_LostFocus() If Len(txtPicFile) Then
If bDirty(vbPicture) Then
imgPreview.Picture = LoadPicture(txtPicFile)
bDirty(vbPicture) = False
End If
End IfEnd Sub
Sub DisablePicField() With txtPicFile
.Enabled = False
.BackColor = vbButtonFace
End With
cmdBrowse(1).Enabled = FalseEnd Sub
Sub EnablePicField() With txtPicFile
.Enabled = True
.BackColor = vbWindowBackground
.Text = ""
End With
cmdBrowse(1).Enabled = True
bDirty(vbPicture) = FalseEnd Sub
[email protected]
1.access中存放图片的字段数据类型设为ole对象;
2.在form中使用image控件,并将其余相应的data控件关联;
3.使用image.picture=loadpicture(filename)即可.
如需要源码,告诉我你的邮件地址,发给你.
^_^