دوست عزیز با وارد کردن پست جدید سعی در با آوردن تاپیک خود نکنید مطمئن باشین درصورت دونستن جواب شما دوستان شمارو راهنمائی خواهند کرد.
برا این منظور function فوق رو تو یه ماژول کپی کنین و یک رکورد ست تعریف کرده و موقع ست کردن رکوردست Read_Excel رو برا رکوردستتون ست کنین.
Option Compare Database
Private Declare Function ts_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean
Private Declare Function ts_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Type tsFileName
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function Read_Excel() As ADODB.Recordset
Dim sFile As String
Dim strFilter As String
Dim lngflags As Long
Dim varFileName As Variant
strFilter = "Microsofr Office Excel (*.xls)" & vbNullChar & "*.xls"
lngflags = FNPathMustExist Or FNFileMustExist _
Or FNHideReadOnly
sFile = GetFileFromUser( _
fOpenFile:=True, _
strFilter:=strFilter, _
rlngflags:=lngflags, _
strDialogTitle:="ãÓíÑ ãæÑÏ äÙÑ ÑÇ ÇäÊÎÇÈ äãÇííÏ")
If Nz(sFile) = vbNullString Then Exit Function
On Error GoTo fix_err
Dim RS As ADODB.Recordset
Set RS = New ADODB.Recordset
Dim sconn As String
RS.CursorLocation = adUseClient
RS.CursorType = adOpenKeyset
RS.LockType = adLockBatchOptimistic
sconn = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sFile
RS.Open "SELECT * FROM [sheet1$]", sconn
Set Read_Excel = RS
Set RS = Nothing
Exit Function
fix_err:
Debug.Print Err.Description + " " + _
Err.Source, vbCritical, "Import"
Err.Clear
End Function
Public Function GetFileFromUser( _
Optional ByRef rlngflags As Long = 0&, _
Optional ByVal strInitialDir As String = "", _
Optional ByVal strFilter As String = "All Files (*.*)" & vbNullChar & "*.*", _
Optional ByVal lngFilterIndex As Long = 1, _
Optional ByVal strDefaultExt As String = "", _
Optional ByVal strFileName As String = "", _
Optional ByVal strDialogTitle As String = "", _
Optional ByVal fOpenFile As Boolean = True) As Variant
On Error GoTo GetFileFromUser_Err
Dim tsFN As tsFileName
Dim strFileTitle As String
Dim fResult As Boolean
' Allocate string space for the returned strings.
strFileName = Left(strFileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With tsFN
.lStructSize = Len(tsFN)
.hwndOwner = Application.hWndAccessApp
.strFilter = strFilter
.nFilterIndex = lngFilterIndex
.strFile = strFileName
.nMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = strDialogTitle
.flags = rlngflags
.strDefExt = strDefaultExt
.strInitialDir = strInitialDir
.hInstance = 0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
.lpfnHook = 0
End With
' Call the function in the windows API
If fOpenFile Then
fResult = ts_apiGetOpenFileName(tsFN)
Else
fResult = ts_apiGetSaveFileName(tsFN)
End If
' If the function call was successful, return the FileName chosen
' by the user. Otherwise return null. Note, the CancelError property
' used by the ActiveX Common Dialog control is not needed. If the
' user presses Cancel, this function will return Null.
If fResult Then
rlngflags = tsFN.flags
GetFileFromUser = tsTrimNull(tsFN.strFile)
Else
GetFileFromUser = ""
End If
GetFileFromUser_End:
On Error GoTo 0
Exit Function
GetFileFromUser_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFiles.GetFileFromUser"
Resume GetFileFromUser_End
End Function
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
Dim i As Integer
i = InStr(strItem, vbNullChar)
If i > 0 Then
tsTrimNull = Left(strItem, i - 1)
Else
tsTrimNull = strItem
End If
tsTrimNull_End:
On Error GoTo 0
Exit Function
tsTrimNull_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFiles.tsTrimNull"
Resume tsTrimNull_End
End Function
دانلود نمونه برنامه
پاسخ با نقل قول
