กระทู้เก่าบอร์ด อ.Yeadram
1,046 3
URL.หัวข้อ /
URL
การสร้างปุ่มนำเข้าข้อมูล
จะสร้างปุ่มเพื่อนำข้อมูลที่เป็นไฟล์เอ็กเซลจากด้านนอกมาลงในตารางค่ะ เคยเห็นในความคิดเห็นของ"คุณรักน้องบิวท์" เป็นโค้ดตามด้านล่างเลยค่ะ (ขออนุญาตินำไปใช้นะคะ"
ส่วนนี้วางไว้ในโมดูล
Option Compare Database
Option Explicit
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'Code courtesy of
'Terry Kreft
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pIDL As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
'** API **
'*********
'[Open File]Dialog Box API
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
'***********
'** CONST **
'***********
'***********
'** CONST **
'***********
'OPENFILENAME flags
Public Const OFN_READONLY = &H1 '[Read Only]Check On
Public Const OFN_OVERWRITEPROMPT = &H2 'Ask Overwrite
Public Const OFN_HIDEREADONLY = &H4 '[Read Only]Hide Checkbox
Public Const OFN_SHOWHELP = &H10 '[Help]Visible
Public Const OFN_ALLOWMULTISELECT = &H200 'Select Multi
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800 'Can not use unexistant path name
Public Const OFN_FILEMUSTEXIST = &H1000 'Can not use unexistant file name
Public Const OFN_CREATEPROMPT = &H2000 'If there is no file,create or not.
Public Const OFN_EXPLORER = &H80000
'*********
'** Val **
'*********
'[Open file] and [Save File]Dialog
Private Type OPENFILENAME
lStructSize As Long 'Size
hwndOwner As Long 'Window's handle
hInstance As Long 'Apprication's instance
lpstrFilter As String 'Filter
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long 'Default file name
lpstrFile As String 'Selected file name
nMaxFile As Long 'Max length of file name
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long 'option
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'--------------------------------------------------------
' FUNC : ShowOpenFileDlg
' aim : Show [Open File]Dialog and get file name
'--------------------------------------------------------
Public Function ShowOpenFileDlg(lnghWnd As Long, strFilter As String, strDefDir As String) As String
Dim strRePathName As String
Dim typOpenFileName As OPENFILENAME
With typOpenFileName
'Set Size
.lStructSize = Len(typOpenFileName)
'Set owner windows handle
.hwndOwner = lnghWnd
'Set Apprication's instance
' .hInstance = App.hInstance
'Set filter
.lpstrFilter = strFilter
'Set active filter name
.nFilterIndex = 1
'Reset [File]box
.lpstrFile = String(256, Chr(0))
'Set max length of file name
.nMaxFile = 256
'pointer for Recieve file's title
.lpstrFileTitle = String(256, Chr(0))
'Set max length of file title
.nMaxFileTitle = 256
'Set default directory
.lpstrInitialDir = strDefDir
'Set dialog's title
.lpstrTitle = "Select File"
'Set option
.flags = OFN_EXPLORER Or OFN_PATHMUSTEXIST _
Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
End With
'Show [Open File]Dialog
If GetOpenFileName(typOpenFileName) = 0 Then
'When Cancel
ShowOpenFileDlg = ""
Else
'If OK,show file name
'purge Null strings
ShowOpenFileDlg = Left(typOpenFileName.lpstrFile, _
InStr(typOpenFileName.lpstrFile, vbNullChar) - 1)
End If
End Function
ส่วนนี้วางไว้ที่ฟอร์ม สร้างปุ่มให้ยูสเซอร์กดเลือกไฟล์
กับเท็กซ์บ๊อกซ์ให้แสดงชื่อพาธกับไฟล์
Dim strFilter As String
strFilter = "All File (*.*)" & vbNullChar
buff = ShowOpenFileDlg(Me.Hwnd, strFilter, "C:\")
Me.txtFolderPath = buff
ปรากฎมาสร้างตามเสร็จเรียบร้อยแล้วสามารถใช้งานปุ่มได้ แต่ไม่รู้ว่าข้อมูลที่นำเข้ามานั้นไปเก็บอยู่ตรงไหนใครทราบช่วยตอบทีค่ะ สารภาพว่าไม่เข้าใจโค้ดเพราะไม่มีพื้นฐานการเขียนโค้ดเลย หรือใครมีวิธีการสร้างปุ่มนำเข้าข้อมูลแบบที่ได้กล่าวมาก็ขอคำแนะนำด้วยค่ะ ขอบคุณค่ะ
ส่วนนี้วางไว้ในโมดูล
Option Compare Database
Option Explicit
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'Code courtesy of
'Terry Kreft
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pIDL As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
'** API **
'*********
'[Open File]Dialog Box API
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
'***********
'** CONST **
'***********
'***********
'** CONST **
'***********
'OPENFILENAME flags
Public Const OFN_READONLY = &H1 '[Read Only]Check On
Public Const OFN_OVERWRITEPROMPT = &H2 'Ask Overwrite
Public Const OFN_HIDEREADONLY = &H4 '[Read Only]Hide Checkbox
Public Const OFN_SHOWHELP = &H10 '[Help]Visible
Public Const OFN_ALLOWMULTISELECT = &H200 'Select Multi
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800 'Can not use unexistant path name
Public Const OFN_FILEMUSTEXIST = &H1000 'Can not use unexistant file name
Public Const OFN_CREATEPROMPT = &H2000 'If there is no file,create or not.
Public Const OFN_EXPLORER = &H80000
'*********
'** Val **
'*********
'[Open file] and [Save File]Dialog
Private Type OPENFILENAME
lStructSize As Long 'Size
hwndOwner As Long 'Window's handle
hInstance As Long 'Apprication's instance
lpstrFilter As String 'Filter
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long 'Default file name
lpstrFile As String 'Selected file name
nMaxFile As Long 'Max length of file name
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long 'option
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'--------------------------------------------------------
' FUNC : ShowOpenFileDlg
' aim : Show [Open File]Dialog and get file name
'--------------------------------------------------------
Public Function ShowOpenFileDlg(lnghWnd As Long, strFilter As String, strDefDir As String) As String
Dim strRePathName As String
Dim typOpenFileName As OPENFILENAME
With typOpenFileName
'Set Size
.lStructSize = Len(typOpenFileName)
'Set owner windows handle
.hwndOwner = lnghWnd
'Set Apprication's instance
' .hInstance = App.hInstance
'Set filter
.lpstrFilter = strFilter
'Set active filter name
.nFilterIndex = 1
'Reset [File]box
.lpstrFile = String(256, Chr(0))
'Set max length of file name
.nMaxFile = 256
'pointer for Recieve file's title
.lpstrFileTitle = String(256, Chr(0))
'Set max length of file title
.nMaxFileTitle = 256
'Set default directory
.lpstrInitialDir = strDefDir
'Set dialog's title
.lpstrTitle = "Select File"
'Set option
.flags = OFN_EXPLORER Or OFN_PATHMUSTEXIST _
Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
End With
'Show [Open File]Dialog
If GetOpenFileName(typOpenFileName) = 0 Then
'When Cancel
ShowOpenFileDlg = ""
Else
'If OK,show file name
'purge Null strings
ShowOpenFileDlg = Left(typOpenFileName.lpstrFile, _
InStr(typOpenFileName.lpstrFile, vbNullChar) - 1)
End If
End Function
ส่วนนี้วางไว้ที่ฟอร์ม สร้างปุ่มให้ยูสเซอร์กดเลือกไฟล์
กับเท็กซ์บ๊อกซ์ให้แสดงชื่อพาธกับไฟล์
Dim strFilter As String
strFilter = "All File (*.*)" & vbNullChar
buff = ShowOpenFileDlg(Me.Hwnd, strFilter, "C:\")
Me.txtFolderPath = buff
ปรากฎมาสร้างตามเสร็จเรียบร้อยแล้วสามารถใช้งานปุ่มได้ แต่ไม่รู้ว่าข้อมูลที่นำเข้ามานั้นไปเก็บอยู่ตรงไหนใครทราบช่วยตอบทีค่ะ สารภาพว่าไม่เข้าใจโค้ดเพราะไม่มีพื้นฐานการเขียนโค้ดเลย หรือใครมีวิธีการสร้างปุ่มนำเข้าข้อมูลแบบที่ได้กล่าวมาก็ขอคำแนะนำด้วยค่ะ ขอบคุณค่ะ
3 Reply in this Topic. Dispaly 1 pages and you are on page number 1
2 @R22587
ขอบคุนค่ะ ตอนนี้ได้โค้ดมาแล้วนะคะเป็นประมาณนี้
Option Compare Database
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Long
Public Const OFN_ALLOWMULTISELECT = &H200&
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000&
Public Const OFN_HIDEREADONLY = &H4&
Public Const OFN_PATHMUSTEXIST = &H800&
Dim db As DAO.Database
Dim tb As DAO.TableDef
Dim i, j As Integer
Dim x, y As Long
Dim sq, sql As String
Dim tbMain As String
Sub ShowFileOpenDialog(ByRef FileList As Collection)
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim FileDir As String
Dim FilePos As Long
Dim PrevFilePos As Long
With OpenFile
.lStructSize = Len(OpenFile)
.hwndOwner = 0
.hInstance = 0
.lpstrFilter = "Excel Files" + Chr(0) + "*.xls" + _
Chr(0) + "All Files (*.*)" + Chr(0) + "*.*" + Chr(0) + Chr(0)
.nFilterIndex = 1
.lpstrFile = String(4096, 0)
.nMaxFile = Len(.lpstrFile) - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = "%windir%\Document and settings\" & Environ("UserName") & "\Desktop\"
.lpstrTitle = "Import Excel"
.flags = OFN_HIDEREADONLY + _
OFN_PATHMUSTEXIST + _
OFN_FILEMUSTEXIST + _
OFN_ALLOWMULTISELECT + _
OFN_EXPLORER
lReturn = GetOpenFileName(OpenFile)
If lReturn <> 0 Then
FilePos = InStr(1, .lpstrFile, Chr(0))
If Mid(.lpstrFile, FilePos + 1, 1) = Chr(0) Then
FileList.Add .lpstrFile
Else
FileDir = Mid(.lpstrFile, 1, FilePos - 1)
Do While True
PrevFilePos = FilePos
FilePos = InStr(PrevFilePos + 1, .lpstrFile, Chr(0))
If FilePos - PrevFilePos > 1 Then
FileList.Add FileDir + "\" + _
Mid(.lpstrFile, PrevFilePos + 1, _
FilePos - PrevFilePos - 1)
Else
Exit Do
End If
Loop
End If
End If
End With
End Sub
Sub CreateQ()
tbMain = "Sheet1" ' ************* table imported
Set db = CurrentDb
x = DMax("cha", "tbChoise") ' ************** table of Choises
sq = ""
For y = 1 To x ' ************** Primary Loop max of choises
sq = sq & "SELECT " & y & " AS choise"
Set tb = db.TableDefs(tbMain)
For i = 1 To tb.Fields.Count ' *************** Secondary Loop Max of fields
sq = sq & ", Sum(IIf([Item" & i & "]='" & y & "',1,0)) AS IT" & Format(i, "00")
Next
Set tb = Nothing
sq = sq & " FROM " & tbMain
sq = sq & " UNION "
Next
sq = Left(sq, Len(sq) - 7) & ";"
On Error Resume Next
db.QueryDefs.Delete "Q1" ' Delete old query
db.CreateQueryDef "Q1", sq ' Make UNION query
db.Close
Set db = Nothing
End Sub
Function Main()
Dim ar As New Collection
ShowFileOpenDialog ar
If ar.Count < 1 Then GoTo Exi
sql = Left(ar.Item(1), InStr(1, ar.Item(1), ".xls", vbTextCompare) + 3)
sq = InputBox("Name of Import table", "Specify Name of New table", "Sheet1")
If sq = "" Then GoTo Exi
tbMain = sq
On Error Resume Next
DoCmd.DeleteObject acTable, tbMain
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel9, tbMain, sql, True
CreateQ
DoCmd.OpenQuery "Q1"
Exit Function
Exi:
MsgBox "No excel's file," & vbCrLf & _
"or....No Table's name," & vbCrLf & vbCrLf & _
"No continue!, Bye", , "CAN NOT CONTINUE"
'Quit
End Function
แต่ว่ามันยังไม่ตรงตามที่ต้องการ คือโค้ดตัวนี้เวลาใช้งานอ่ะค่ะ พอเรานำเข้าข้อมูลมาเป็นครั้งที่2แล้วตั้งชื่อตารางเป็นชื่อเดียวกับการนำเข้าครั้งแรก มันก้จะกลายเป็นว่าตารางนั้นๆจะจำค่าแค่ข้อมูลการนำเข้าครั้งล่าสุดเท่านั้นค่ะ ข้อมูลที่เคยนำเข้าไว้ครั้งแรกหายไปเลย อยากจะให้มันรวมกันอ่ะค่ะ เหมือนกับว่าเวลาเรามีข้อมูลสมาชิกเพิ่มขึ้นก็อยากให้มันไปบันทึกรวมกันอยู่ในตารางเดียวกันกับสมาชิกก่อนหน้าแบบนี้อ่ะค่ะ ใครพอจะช่วยแก้ไขโค้ดให้ได้ตามนี้บ้างมั้ยค่ะ ขอบคุณค่ะ
Option Compare Database
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Long
Public Const OFN_ALLOWMULTISELECT = &H200&
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000&
Public Const OFN_HIDEREADONLY = &H4&
Public Const OFN_PATHMUSTEXIST = &H800&
Dim db As DAO.Database
Dim tb As DAO.TableDef
Dim i, j As Integer
Dim x, y As Long
Dim sq, sql As String
Dim tbMain As String
Sub ShowFileOpenDialog(ByRef FileList As Collection)
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim FileDir As String
Dim FilePos As Long
Dim PrevFilePos As Long
With OpenFile
.lStructSize = Len(OpenFile)
.hwndOwner = 0
.hInstance = 0
.lpstrFilter = "Excel Files" + Chr(0) + "*.xls" + _
Chr(0) + "All Files (*.*)" + Chr(0) + "*.*" + Chr(0) + Chr(0)
.nFilterIndex = 1
.lpstrFile = String(4096, 0)
.nMaxFile = Len(.lpstrFile) - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = "%windir%\Document and settings\" & Environ("UserName") & "\Desktop\"
.lpstrTitle = "Import Excel"
.flags = OFN_HIDEREADONLY + _
OFN_PATHMUSTEXIST + _
OFN_FILEMUSTEXIST + _
OFN_ALLOWMULTISELECT + _
OFN_EXPLORER
lReturn = GetOpenFileName(OpenFile)
If lReturn <> 0 Then
FilePos = InStr(1, .lpstrFile, Chr(0))
If Mid(.lpstrFile, FilePos + 1, 1) = Chr(0) Then
FileList.Add .lpstrFile
Else
FileDir = Mid(.lpstrFile, 1, FilePos - 1)
Do While True
PrevFilePos = FilePos
FilePos = InStr(PrevFilePos + 1, .lpstrFile, Chr(0))
If FilePos - PrevFilePos > 1 Then
FileList.Add FileDir + "\" + _
Mid(.lpstrFile, PrevFilePos + 1, _
FilePos - PrevFilePos - 1)
Else
Exit Do
End If
Loop
End If
End If
End With
End Sub
Sub CreateQ()
tbMain = "Sheet1" ' ************* table imported
Set db = CurrentDb
x = DMax("cha", "tbChoise") ' ************** table of Choises
sq = ""
For y = 1 To x ' ************** Primary Loop max of choises
sq = sq & "SELECT " & y & " AS choise"
Set tb = db.TableDefs(tbMain)
For i = 1 To tb.Fields.Count ' *************** Secondary Loop Max of fields
sq = sq & ", Sum(IIf([Item" & i & "]='" & y & "',1,0)) AS IT" & Format(i, "00")
Next
Set tb = Nothing
sq = sq & " FROM " & tbMain
sq = sq & " UNION "
Next
sq = Left(sq, Len(sq) - 7) & ";"
On Error Resume Next
db.QueryDefs.Delete "Q1" ' Delete old query
db.CreateQueryDef "Q1", sq ' Make UNION query
db.Close
Set db = Nothing
End Sub
Function Main()
Dim ar As New Collection
ShowFileOpenDialog ar
If ar.Count < 1 Then GoTo Exi
sql = Left(ar.Item(1), InStr(1, ar.Item(1), ".xls", vbTextCompare) + 3)
sq = InputBox("Name of Import table", "Specify Name of New table", "Sheet1")
If sq = "" Then GoTo Exi
tbMain = sq
On Error Resume Next
DoCmd.DeleteObject acTable, tbMain
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel9, tbMain, sql, True
CreateQ
DoCmd.OpenQuery "Q1"
Exit Function
Exi:
MsgBox "No excel's file," & vbCrLf & _
"or....No Table's name," & vbCrLf & vbCrLf & _
"No continue!, Bye", , "CAN NOT CONTINUE"
'Quit
End Function
แต่ว่ามันยังไม่ตรงตามที่ต้องการ คือโค้ดตัวนี้เวลาใช้งานอ่ะค่ะ พอเรานำเข้าข้อมูลมาเป็นครั้งที่2แล้วตั้งชื่อตารางเป็นชื่อเดียวกับการนำเข้าครั้งแรก มันก้จะกลายเป็นว่าตารางนั้นๆจะจำค่าแค่ข้อมูลการนำเข้าครั้งล่าสุดเท่านั้นค่ะ ข้อมูลที่เคยนำเข้าไว้ครั้งแรกหายไปเลย อยากจะให้มันรวมกันอ่ะค่ะ เหมือนกับว่าเวลาเรามีข้อมูลสมาชิกเพิ่มขึ้นก็อยากให้มันไปบันทึกรวมกันอยู่ในตารางเดียวกันกับสมาชิกก่อนหน้าแบบนี้อ่ะค่ะ ใครพอจะช่วยแก้ไขโค้ดให้ได้ตามนี้บ้างมั้ยค่ะ ขอบคุณค่ะ
3 @R22588
ต้องขอออกตัวก่อนนะคะว่าไม่ได้เข้าใจโค้ดเลย พอดีหามาจากโปรแกรมที่แจกฟรีแล้วตรงตามงานเราอ่ะค่ะ รบกวนช่วยดูให้หน่อยนะคะ
Time: 0.2505s
ส่วนคำสั่งสำหรับการนำเข้าจากเอ็กซ์เซล ให้ไปที่หน้าโอมเพจของที่นี่ แล้วใส่คำ acimport ในช่องค้นหาครับ มีหลายคำถามคำตอบครับ