Добрый день! Нужно результат запроса в ACCESS поместить в ListBox1 Excel минуя этап его выгрузки на лист (кажется так делать можно, но не получается). В приложенных файлах сама база данных и файл с макросом и формой. На всякий случай макрос с запросом тоже сюда выкладываю. [vba]
Код
Sub From_Access_In_Excel() ' Application.ScreenUpdating = False Dim dbe As Object ' Dim db As Object ' Dim rst As Object ' Void = " & Space(1) & "
If ActiveSheet.Name = "ДляПримера" Then FullWay_1 = ActiveWorkbook.Path ' FileNameBD = "DB.accdb" FullWay = FullWay_1 & "\" & FileNameBD
Set dbe = CreateObject("DAO.DBEngine.120") ' Set db = dbe.OpenDatabase(FullWay) '
Set rst = db.OpenRecordset(sSQL) Range("A2").CopyFromRecordset rst End If
Set dbe = Nothing Set db = Nothing Set rst = Nothing
WorkForm_1.Hide Application.ScreenUpdating = True End Sub
[/vba]
Добрый день! Нужно результат запроса в ACCESS поместить в ListBox1 Excel минуя этап его выгрузки на лист (кажется так делать можно, но не получается). В приложенных файлах сама база данных и файл с макросом и формой. На всякий случай макрос с запросом тоже сюда выкладываю. [vba]
Код
Sub From_Access_In_Excel() ' Application.ScreenUpdating = False Dim dbe As Object ' Dim db As Object ' Dim rst As Object ' Void = " & Space(1) & "
If ActiveSheet.Name = "ДляПримера" Then FullWay_1 = ActiveWorkbook.Path ' FileNameBD = "DB.accdb" FullWay = FullWay_1 & "\" & FileNameBD
Set dbe = CreateObject("DAO.DBEngine.120") ' Set db = dbe.OpenDatabase(FullWay) '
Елена, Доброго времени суток. Можете выложить код сюда? Пожалуйста. Пишу проект схожий как и у ОлеггелО, точнее не могу сказать так как нет возможности скачать его файлы примеры. И столкнулся с тем же вопрос. Пришлось бы мне тоже аналогичную тему создавать. На лист могу вывалить рекордсет а вот сразу из базы в ListBox нет. Спасибо вам заранее. Мира и Здоровья!
Update! Разобрался сам. Выложу свой пример кода Пользовательской формы сюда, может кому в будущем пригодится. Но, сразу скажу что код не подойдёт для данной темы и в моём коде данные заносится и на лист и сразу заполняет ListBox1 данными из Recordset-а. Можно удалить данный блок из кода тогда останется только заполнение данными в ListBox1 непосредственно из Recordset-а. Возможно адаптация.
[vba]
Код
Option Explicit Private Const GWL_STYLE As Long = -16& Private Const GWL_EXSTYLE = -20& Private Const WS_CAPTION As Long = &HC00000 Private Const WS_BORDER As Long = &H800000
#If VBA7 Then Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long #Else Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long #End If
Private Sub CheckBox1_Click()
If CheckBox1 = True Then CheckBox1.Caption = "ACTIVE" CheckBox2.Enabled = False Else CheckBox1.Caption = "ALL ACTIVE STATUS" CheckBox2.Enabled = True End If
UserForm_Initialize End Sub
Private Sub CheckBox2_Click()
If CheckBox2 = True Then CheckBox2.Caption = "IN ACTIVE" CheckBox1.Enabled = False Else CheckBox2.Caption = "ALL IN ACTIVE STATUS" CheckBox1.Enabled = True End If
UserForm_Initialize End Sub
' BUTTON "CLOSE FORM" Sub CommandButton5_Click() iFlag = False Unload Me End Sub
Private Sub ListBox1_Click() Dim i As Long i = Me.ListBox1.ListIndex
If Me.ListBox1.List(Me.ListBox1.ListIndex, 0) <> "" Then i = ListBox1.ListIndex + 2 Application.GoTo Sheet1.Range("A" & i & ":AL" & i) End If
End Sub
Private Sub UserForm_Initialize() Dim ihWnd, hStyle
If Val(Application.Version) < 9 Then ihWnd = FindWindow("ThunderXFrame", Me.Caption) Else ihWnd = FindWindow("ThunderDFrame", Me.Caption) End If
hStyle = GetWindowLong(ihWnd, -16&) SetWindowLong ihWnd, -16&, hStyle And Not &H80000
' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim SQL As String, ColName As String Dim i As Long, j As Long, numCol As Long On Error GoTo Whoa Application.ScreenUpdating = False Sheet1.Cells.ClearContents
Dim dbPath As String dbPath = "D:\TEST.accdb"
Dim cnn As ADODB.Connection Set cnn = New ADODB.Connection cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
If CheckBox1 = True Then SQL = "SELECT * FROM CREWALLDATA WHERE STATUS = 'Active';" ElseIf CheckBox2 = True Then SQL = "SELECT * FROM CREWALLDATA WHERE STATUS = 'InActive';" Else SQL = "SELECT * FROM CREWALLDATA " End If
Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then rs.Close cnn.Close Set rs = Nothing Set cnn = Nothing Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records" Exit Sub End If
With Sheet1
For i = 0 To rs.Fields.Count - 1 .Cells(1, i + 1) = rs.Fields(i).Name Next
.Range("A2").CopyFromRecordset rs .Cells.Columns.AutoFit End With
For j = 0 To numCol ColName = rs.Fields(j).Name .List(i, j) = rs.Fields(ColName).Value Next j
i = i + 1 rs.MoveNext Loop
End With
LetsContinue: Application.ScreenUpdating = True On Error Resume Next rs.Close Set rs = Nothing cnn.Close Set cnn = Nothing On Error GoTo 0 Exit Sub Whoa: MsgBox "Error Description: " & Err.Description & vbCrLf & _ "Error at line: " & Erl & vbCrLf & _ "Error Number: " & Err.Number Resume LetsContinue ' """""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" End Sub
[/vba]
Елена, Доброго времени суток. Можете выложить код сюда? Пожалуйста. Пишу проект схожий как и у ОлеггелО, точнее не могу сказать так как нет возможности скачать его файлы примеры. И столкнулся с тем же вопрос. Пришлось бы мне тоже аналогичную тему создавать. На лист могу вывалить рекордсет а вот сразу из базы в ListBox нет. Спасибо вам заранее. Мира и Здоровья!
Update! Разобрался сам. Выложу свой пример кода Пользовательской формы сюда, может кому в будущем пригодится. Но, сразу скажу что код не подойдёт для данной темы и в моём коде данные заносится и на лист и сразу заполняет ListBox1 данными из Recordset-а. Можно удалить данный блок из кода тогда останется только заполнение данными в ListBox1 непосредственно из Recordset-а. Возможно адаптация.
[vba]
Код
Option Explicit Private Const GWL_STYLE As Long = -16& Private Const GWL_EXSTYLE = -20& Private Const WS_CAPTION As Long = &HC00000 Private Const WS_BORDER As Long = &H800000
#If VBA7 Then Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long #Else Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long #End If
Private Sub CheckBox1_Click()
If CheckBox1 = True Then CheckBox1.Caption = "ACTIVE" CheckBox2.Enabled = False Else CheckBox1.Caption = "ALL ACTIVE STATUS" CheckBox2.Enabled = True End If
UserForm_Initialize End Sub
Private Sub CheckBox2_Click()
If CheckBox2 = True Then CheckBox2.Caption = "IN ACTIVE" CheckBox1.Enabled = False Else CheckBox2.Caption = "ALL IN ACTIVE STATUS" CheckBox1.Enabled = True End If
UserForm_Initialize End Sub
' BUTTON "CLOSE FORM" Sub CommandButton5_Click() iFlag = False Unload Me End Sub
Private Sub ListBox1_Click() Dim i As Long i = Me.ListBox1.ListIndex
If Me.ListBox1.List(Me.ListBox1.ListIndex, 0) <> "" Then i = ListBox1.ListIndex + 2 Application.GoTo Sheet1.Range("A" & i & ":AL" & i) End If
End Sub
Private Sub UserForm_Initialize() Dim ihWnd, hStyle
If Val(Application.Version) < 9 Then ihWnd = FindWindow("ThunderXFrame", Me.Caption) Else ihWnd = FindWindow("ThunderDFrame", Me.Caption) End If
hStyle = GetWindowLong(ihWnd, -16&) SetWindowLong ihWnd, -16&, hStyle And Not &H80000
' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim SQL As String, ColName As String Dim i As Long, j As Long, numCol As Long On Error GoTo Whoa Application.ScreenUpdating = False Sheet1.Cells.ClearContents
Dim dbPath As String dbPath = "D:\TEST.accdb"
Dim cnn As ADODB.Connection Set cnn = New ADODB.Connection cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
If CheckBox1 = True Then SQL = "SELECT * FROM CREWALLDATA WHERE STATUS = 'Active';" ElseIf CheckBox2 = True Then SQL = "SELECT * FROM CREWALLDATA WHERE STATUS = 'InActive';" Else SQL = "SELECT * FROM CREWALLDATA " End If
Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then rs.Close cnn.Close Set rs = Nothing Set cnn = Nothing Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records" Exit Sub End If
With Sheet1
For i = 0 To rs.Fields.Count - 1 .Cells(1, i + 1) = rs.Fields(i).Name Next
.Range("A2").CopyFromRecordset rs .Cells.Columns.AutoFit End With
Pelena, спасибо! Это практически то, что нужно. Единственное, в Вашем коде данные в ListBox1 загружаются по столбикам (пробелы между словами длинные), нужно что бы был один пробел между словами. Но с этим, я думаю, смогу справиться сам. Спасибо ещё раз!
Pelena, спасибо! Это практически то, что нужно. Единственное, в Вашем коде данные в ListBox1 загружаются по столбикам (пробелы между словами длинные), нужно что бы был один пробел между словами. Но с этим, я думаю, смогу справиться сам. Спасибо ещё раз!ОлеггелО
Сообщение отредактировал ОлеггелО - Суббота, 20.04.2024, 06:34
Доброе утро. Да я, собственно, использовала код из первого поста при инициализации формы
[vba]
Код
Private Sub UserForm_Initialize() Dim dbe As Object ' Dim db As Object ' Dim rst As Object ' Void = "," FullWay_1 = ActiveWorkbook.Path ' FileNameBD = "DB.accdb" FullWay = FullWay_1 & "\" & FileNameBD
Set dbe = CreateObject("DAO.DBEngine.120") ' Set db = dbe.OpenDatabase(FullWay) '
Set rst = db.OpenRecordset(ssql) With Me.ListBox1 Do While Not rst.EOF If Not IsNull(rst.Fields(0)) Then .AddItem rst.Fields(0) .List(.ListCount - 1, 1) = rst.Fields(1) .List(.ListCount - 1, 2) = rst.Fields(2) .List(.ListCount - 1, 3) = rst.Fields(3) End If rst.MoveNext Loop End With
Set dbe = Nothing Set db = Nothing Set rst = Nothing
Доброе утро. Да я, собственно, использовала код из первого поста при инициализации формы
[vba]
Код
Private Sub UserForm_Initialize() Dim dbe As Object ' Dim db As Object ' Dim rst As Object ' Void = "," FullWay_1 = ActiveWorkbook.Path ' FileNameBD = "DB.accdb" FullWay = FullWay_1 & "\" & FileNameBD
Set dbe = CreateObject("DAO.DBEngine.120") ' Set db = dbe.OpenDatabase(FullWay) '
Set rst = db.OpenRecordset(ssql) With Me.ListBox1 Do While Not rst.EOF If Not IsNull(rst.Fields(0)) Then .AddItem rst.Fields(0) .List(.ListCount - 1, 1) = rst.Fields(1) .List(.ListCount - 1, 2) = rst.Fields(2) .List(.ListCount - 1, 3) = rst.Fields(3) End If rst.MoveNext Loop End With
Set dbe = Nothing Set db = Nothing Set rst = Nothing
MikeVol, спасибо и Вам! Но код сделанный Pelena для меня более понятен и, соответственно, лучше поддаётся корректировке. Pelena, скорректировал всего одну строку, а именно написал так: [vba]
[/vba] Таким образом получилось всё, что я хотел - спасибо ещё раз!
MikeVol, спасибо и Вам! Но код сделанный Pelena для меня более понятен и, соответственно, лучше поддаётся корректировке. Pelena, скорректировал всего одну строку, а именно написал так: [vba]