Захотелось мне пополнить свою коллекцию "полезняшек" аналогом MsgBox, но ListBox, которому список передаётся массивом, а выбор из списка производится по DblClick В итоге я хочу сделать надстройку с Public-функцией LstBox, применяемой точно так же "легко и просто" как и MsgBox. Элемент ListView, к сожалению, по умолчанию в MSForms отсутствует, надо подключать библиотеки и референсы. Поэтому для обеспечения лучшей переносимости кода с компа на комп и из приложения в приложение от его применения пришлось отказаться. Поставленным себе условием было то, чтобы весь код был в одной процедуре, которую с минимальными доработками можно будет потом добавлять и использовать в других приложениях. Поэтому UserForm с ListBox на ней решил создавать программно. Покумекал сам. Ребята здесь подмогли советами. В общем, вот какая функция получилась:
[vba]
Код
Function LstBox(ListArray, Optional Title$) As String ' создание UserForm с ListBox Dim oDoc: Set oDoc = ThisWorkbook ' в других объектных моделях необходимо назначить соответствующие объекты (в Visio - ThisDocument) Dim oFrm, oListBox If Not IsArray(ListArray) Then ListArray = Split(ListArray & Chr(35), Chr(35)) ' защита на случай если ListArray не массив Dim sCodeStr$ sCodeStr = "Private Sub UserForm_Initialize()" & vbCrLf & _ " With Me.ListBox1" & vbCrLf & _ " .Top = Me.Top: .Left = Me.Left" & vbCrLf & _ " .Height = Me.Height: .Width = Me.Width" & vbCrLf & _ " .List = Split(.Tag, Chr(135))" & vbCrLf & _ " End With" & vbCrLf & _ "End Sub" & vbCrLf & _ "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)" & vbCrLf & _ " Me.Tag = Me.ListBox1.Text: Me.Hide" & vbCrLf & _ "End Sub" Set oFrm = oDoc.VBProject.VBComponents.Add(3) ' vbext_ct_StdModule == 1 , vbext_ct_ClassModule == 2 , vbext_ct_MSForm == 3 With oFrm .Properties("Width") = 350 ' или .Properties(42) .Properties("Height") = 150 ' или .Properties(43) .Properties("Caption") = Title Set oListBox = .Designer.Controls.Add("Forms.Listbox.1") oListBox.Tag = Join(ListArray, Chr(135)) 'передача списка в форму через параметр ListBox.Tag в виде стринга с разделителем chr(135)=‡ With .CodeModule: .InsertLines .CountOfDeclarationLines + 1, sCodeStr: End With ' без With … End With, почему-то не работает VBA.UserForms.Add(.Name).Show On Error Resume Next ' ошибка возникнет если форму закрыть "крестиком" LstBox = VBA.UserForms(VBA.UserForms.Count - 1).Tag ' возврат значения из формы через параметр UserForm.Tag End With oDoc.VBProject.VBComponents.Remove VBComponent:=oFrm ' удаление временной формы (при отладке можно закомментировать) End Function
[/vba]
Функция имеет один обязательный аргумент ListArray - массив значений, которые должны выводиться в LietBox'е на открывающейся форме, и опциональный аргумент Title - заголовок выводимой формы. Функция возвращает строковую переменную - текст выбранного даблкликом пункта LietBox'а или пустую строку "" , если форму закрыли "крестиком". Для проверки работы функции написал ещё пару процедур:
[vba]
Код
Private Sub test_LstBox() ' тестирование LstBox On Error Resume Next Dim X: Set X = ActiveWorkbook.VBProject ' проверка доступности .VBProject If Err Then MsgBox "Настройки безопасности не позволяют выполнить макрос", vbCritical: On Error GoTo 0: Exit Sub 'MsgBox LstBox(GetListItems, "Select Item") X = LstBox(GetListItems) ', "Select Item") If X = "" Then MsgBox "Item Not Selected!", vbCritical: Exit Sub MsgBox X End Sub
Private Function GetListItems() ' получить массив значений для заполнения ListBox Dim xVal With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare ' Создаем словарь .Add ">> " & ActiveSheet.Name & " <<", "" ' пусть текущий документ будет первым в списке For Each xVal In ActiveWorkbook.Worksheets: .Add xVal.Name, "": Next xVal ' далее - другие открытые документы .Add "<< " & "New Document" & " >>", "" ' ну и ещё что-нибудь в конец списка GetListItems = .Keys ' массив ключей копируем в возвращаемый функцией массив End With End Function
[/vba]
Всё, вроде бы, отлично работает! НО! Функция доступна для прямого вызова (без указания файла и модуля, где она находится) только из модулей своего проекта VBA А цель была такая, чтобы её можно было использовать свободно откуда угодно так же просто как и MsgBox Попытался её разместить в стандартном модуле Personal.xls - из других файлов напрямую не видна Запихнул в надстройку - всё равно она не доступна из других книг... Конечно, процедура не большая и в крайнем случае можно её держать в Personal.xls и "по нужде" копировать в книги, где она будет применяться. Но как-то это не красиво... Есть у кого-нибудь мысли, как добиться прямой видимости функции?
Захотелось мне пополнить свою коллекцию "полезняшек" аналогом MsgBox, но ListBox, которому список передаётся массивом, а выбор из списка производится по DblClick В итоге я хочу сделать надстройку с Public-функцией LstBox, применяемой точно так же "легко и просто" как и MsgBox. Элемент ListView, к сожалению, по умолчанию в MSForms отсутствует, надо подключать библиотеки и референсы. Поэтому для обеспечения лучшей переносимости кода с компа на комп и из приложения в приложение от его применения пришлось отказаться. Поставленным себе условием было то, чтобы весь код был в одной процедуре, которую с минимальными доработками можно будет потом добавлять и использовать в других приложениях. Поэтому UserForm с ListBox на ней решил создавать программно. Покумекал сам. Ребята здесь подмогли советами. В общем, вот какая функция получилась:
[vba]
Код
Function LstBox(ListArray, Optional Title$) As String ' создание UserForm с ListBox Dim oDoc: Set oDoc = ThisWorkbook ' в других объектных моделях необходимо назначить соответствующие объекты (в Visio - ThisDocument) Dim oFrm, oListBox If Not IsArray(ListArray) Then ListArray = Split(ListArray & Chr(35), Chr(35)) ' защита на случай если ListArray не массив Dim sCodeStr$ sCodeStr = "Private Sub UserForm_Initialize()" & vbCrLf & _ " With Me.ListBox1" & vbCrLf & _ " .Top = Me.Top: .Left = Me.Left" & vbCrLf & _ " .Height = Me.Height: .Width = Me.Width" & vbCrLf & _ " .List = Split(.Tag, Chr(135))" & vbCrLf & _ " End With" & vbCrLf & _ "End Sub" & vbCrLf & _ "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)" & vbCrLf & _ " Me.Tag = Me.ListBox1.Text: Me.Hide" & vbCrLf & _ "End Sub" Set oFrm = oDoc.VBProject.VBComponents.Add(3) ' vbext_ct_StdModule == 1 , vbext_ct_ClassModule == 2 , vbext_ct_MSForm == 3 With oFrm .Properties("Width") = 350 ' или .Properties(42) .Properties("Height") = 150 ' или .Properties(43) .Properties("Caption") = Title Set oListBox = .Designer.Controls.Add("Forms.Listbox.1") oListBox.Tag = Join(ListArray, Chr(135)) 'передача списка в форму через параметр ListBox.Tag в виде стринга с разделителем chr(135)=‡ With .CodeModule: .InsertLines .CountOfDeclarationLines + 1, sCodeStr: End With ' без With … End With, почему-то не работает VBA.UserForms.Add(.Name).Show On Error Resume Next ' ошибка возникнет если форму закрыть "крестиком" LstBox = VBA.UserForms(VBA.UserForms.Count - 1).Tag ' возврат значения из формы через параметр UserForm.Tag End With oDoc.VBProject.VBComponents.Remove VBComponent:=oFrm ' удаление временной формы (при отладке можно закомментировать) End Function
[/vba]
Функция имеет один обязательный аргумент ListArray - массив значений, которые должны выводиться в LietBox'е на открывающейся форме, и опциональный аргумент Title - заголовок выводимой формы. Функция возвращает строковую переменную - текст выбранного даблкликом пункта LietBox'а или пустую строку "" , если форму закрыли "крестиком". Для проверки работы функции написал ещё пару процедур:
[vba]
Код
Private Sub test_LstBox() ' тестирование LstBox On Error Resume Next Dim X: Set X = ActiveWorkbook.VBProject ' проверка доступности .VBProject If Err Then MsgBox "Настройки безопасности не позволяют выполнить макрос", vbCritical: On Error GoTo 0: Exit Sub 'MsgBox LstBox(GetListItems, "Select Item") X = LstBox(GetListItems) ', "Select Item") If X = "" Then MsgBox "Item Not Selected!", vbCritical: Exit Sub MsgBox X End Sub
Private Function GetListItems() ' получить массив значений для заполнения ListBox Dim xVal With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare ' Создаем словарь .Add ">> " & ActiveSheet.Name & " <<", "" ' пусть текущий документ будет первым в списке For Each xVal In ActiveWorkbook.Worksheets: .Add xVal.Name, "": Next xVal ' далее - другие открытые документы .Add "<< " & "New Document" & " >>", "" ' ну и ещё что-нибудь в конец списка GetListItems = .Keys ' массив ключей копируем в возвращаемый функцией массив End With End Function
[/vba]
Всё, вроде бы, отлично работает! НО! Функция доступна для прямого вызова (без указания файла и модуля, где она находится) только из модулей своего проекта VBA А цель была такая, чтобы её можно было использовать свободно откуда угодно так же просто как и MsgBox Попытался её разместить в стандартном модуле Personal.xls - из других файлов напрямую не видна Запихнул в надстройку - всё равно она не доступна из других книг... Конечно, процедура не большая и в крайнем случае можно её держать в Personal.xls и "по нужде" копировать в книги, где она будет применяться. Но как-то это не красиво... Есть у кого-нибудь мысли, как добиться прямой видимости функции?Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Пятница, 02.12.2016, 21:31
К стати, для преобразования кода процедур, скопированного в буфер обмена, в стринг, который можно программно выводить через MsgBox , Debug.Print или ещё куда надо, я слепил ещё одну полезную процедурку:
[vba]
Код
' =========== Утилита подготовки стрингов для вставки в .CodeModule ================= Private Sub Get_Code_String() ' преобразование текстов кодов процедур в стринги ' текст кодов процедур, скопированный в буфер обмена, преобразовать в стринги в соответствии с правилами VBE и поместить в буфер обмена Dim sCode$, sText$, sString$ With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .GetFromClipBoard: sCode = .GetText: End With ' получить текст кода процедур из буфера обмена sText = Replace(sCode, """", """""") ' замена " на "" sString = """" & Replace(sText, vbCrLf, """ & vbCrLf & _" & vbCrLf & """") & """" ' замена возвратов каретки на их коды в стринге 'Debug.Print sText With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText sString: .PutInClipBoard: End With ' поместить текст стринга в буфер обмена End Sub
[/vba]
Юзать проще простого: скопировал нужный текст или код, вызвал процедуру, набрал на клаве Debug.Print или MsgBox и нажал Ctrl+V
К стати, для преобразования кода процедур, скопированного в буфер обмена, в стринг, который можно программно выводить через MsgBox , Debug.Print или ещё куда надо, я слепил ещё одну полезную процедурку:
[vba]
Код
' =========== Утилита подготовки стрингов для вставки в .CodeModule ================= Private Sub Get_Code_String() ' преобразование текстов кодов процедур в стринги ' текст кодов процедур, скопированный в буфер обмена, преобразовать в стринги в соответствии с правилами VBE и поместить в буфер обмена Dim sCode$, sText$, sString$ With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .GetFromClipBoard: sCode = .GetText: End With ' получить текст кода процедур из буфера обмена sText = Replace(sCode, """", """""") ' замена " на "" sString = """" & Replace(sText, vbCrLf, """ & vbCrLf & _" & vbCrLf & """") & """" ' замена возвратов каретки на их коды в стринге 'Debug.Print sText With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText sString: .PutInClipBoard: End With ' поместить текст стринга в буфер обмена End Sub
[/vba]
Юзать проще простого: скопировал нужный текст или код, вызвал процедуру, набрал на клаве Debug.Print или MsgBox и нажал Ctrl+VAlex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Пятница, 02.12.2016, 19:31
Спасибо, Слава. Как надстройку-то я сохранил, а вот ребутнуть Excel и в "Надстройках" и референсах подключить забыл. Сейчас попробую. _______________________ Не вышло: в референсах с чем-то конфликтует, говорит, что имена какие-то задвоились, но не говорит какие. Будем искать.
Спасибо, Слава. Как надстройку-то я сохранил, а вот ребутнуть Excel и в "Надстройках" и референсах подключить забыл. Сейчас попробую. _______________________ Не вышло: в референсах с чем-то конфликтует, говорит, что имена какие-то задвоились, но не говорит какие. Будем искать.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Пятница, 02.12.2016, 15:36
Поковырялся дома. Получилось. Оказывается, нужно было не только имя файла надстройки дать уникальное, но ещё и VBA Project Name, которое даётся всем проектам по умолчанию одинаковое - VBAProject, заменить на уникальное имя. Сохранил файл как MyFunction.xla и переименовал проект в MyFunction. Сначала в новом файле не заработало. Но потом, когда я назначил ссылку в референсах, заработало. Вот и следующий вопрос: что сделать, чтобы ссылка на самодельную надстройку мапилась в референсах автоматически для всех открытых файлов?
Поковырялся дома. Получилось. Оказывается, нужно было не только имя файла надстройки дать уникальное, но ещё и VBA Project Name, которое даётся всем проектам по умолчанию одинаковое - VBAProject, заменить на уникальное имя. Сохранил файл как MyFunction.xla и переименовал проект в MyFunction. Сначала в новом файле не заработало. Но потом, когда я назначил ссылку в референсах, заработало. Вот и следующий вопрос: что сделать, чтобы ссылка на самодельную надстройку мапилась в референсах автоматически для всех открытых файлов?Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Пятница, 02.12.2016, 22:28
слепил из того, что было остается придумать откуда и по какому триггеру запускать AddReference [vba]
Код
Option Explicit Private Declare Function GetClassName& Lib "user32" Alias "GetClassNameA" (ByVal hwnd&, ByVal lpClassName$, ByVal nMaxCount&) Private Declare Function AccessibleObjectFromWindow& Lib "oleacc" (ByVal hwnd&, ByVal dwId&, riid As GUID, xlWB As Object) Private Declare Function GetDesktopWindow& Lib "user32" () Private Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&) Private Const GW_HWNDNEXT = 2 Private Const GW_CHILD = 5 Private Const OBJID_NATIVEOM = &HFFFFFFF0 Private Type GUID lData1 As Long iData2 As Integer iData3 As Integer aBData4(0 To 7) As Byte End Type Private IDispatch As GUID, oWnd As Window Public Sub AddReference() Dim i& With IDispatch .lData1 = &H20400: .iData2 = &H0: .iData3 = &H0 .aBData4(0) = &HC0: .aBData4(1) = &H0: .aBData4(2) = &H0 .aBData4(3) = &H0: .aBData4(4) = &H0: .aBData4(5) = &H0 .aBData4(6) = &H0: .aBData4(7) = &H46 End With Referece2AllWorkbooks 0, "EXCEL7", 0, 0, 0, Application.UserLibraryPath & "MyFunction.xla" Set oWnd = Nothing End Sub Private Function Referece2AllWorkbooks&(hWndStart&, ClassName$, level&, lHolder&, lCnt&, sFile$) Dim hwnd&, sWindowTitle$, sClassName$, wb as Workbook If level = 0 Then If hWndStart = 0 Then hWndStart = GetDesktopWindow() End If End If
'Get first child window '---------------------- hwnd = GetWindow(hWndStart, GW_CHILD)
Do While hwnd > 0 'Search children by recursion '---------------------------- lHolder = Referece2AllWorkbooks(hwnd, ClassName, level, lHolder, lCnt, sFile)
'get the class name '------------------ sClassName = Space$(255) r = GetClassName(hwnd, sClassName, 255) sClassName = Left$(sClassName, r)
If sClassName Like ClassName & "*" Or sClassName = ClassName Then Referece2AllWorkbooks = hwnd lHolder = hwnd AccessibleObjectFromWindow hwnd, OBJID_NATIVEOM, IDispatch, oWnd If Not oWnd Is Nothing Then If oWnd.Visible Then lCnt = lCnt + 1 On Error Resume Next For Each wb In oWnd.Application.Workbooks wb.VBProject.References.AddFromFile sFile Next End If End If End If
слепил из того, что было остается придумать откуда и по какому триггеру запускать AddReference [vba]
Код
Option Explicit Private Declare Function GetClassName& Lib "user32" Alias "GetClassNameA" (ByVal hwnd&, ByVal lpClassName$, ByVal nMaxCount&) Private Declare Function AccessibleObjectFromWindow& Lib "oleacc" (ByVal hwnd&, ByVal dwId&, riid As GUID, xlWB As Object) Private Declare Function GetDesktopWindow& Lib "user32" () Private Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&) Private Const GW_HWNDNEXT = 2 Private Const GW_CHILD = 5 Private Const OBJID_NATIVEOM = &HFFFFFFF0 Private Type GUID lData1 As Long iData2 As Integer iData3 As Integer aBData4(0 To 7) As Byte End Type Private IDispatch As GUID, oWnd As Window Public Sub AddReference() Dim i& With IDispatch .lData1 = &H20400: .iData2 = &H0: .iData3 = &H0 .aBData4(0) = &HC0: .aBData4(1) = &H0: .aBData4(2) = &H0 .aBData4(3) = &H0: .aBData4(4) = &H0: .aBData4(5) = &H0 .aBData4(6) = &H0: .aBData4(7) = &H46 End With Referece2AllWorkbooks 0, "EXCEL7", 0, 0, 0, Application.UserLibraryPath & "MyFunction.xla" Set oWnd = Nothing End Sub Private Function Referece2AllWorkbooks&(hWndStart&, ClassName$, level&, lHolder&, lCnt&, sFile$) Dim hwnd&, sWindowTitle$, sClassName$, wb as Workbook If level = 0 Then If hWndStart = 0 Then hWndStart = GetDesktopWindow() End If End If
'Get first child window '---------------------- hwnd = GetWindow(hWndStart, GW_CHILD)
Do While hwnd > 0 'Search children by recursion '---------------------------- lHolder = Referece2AllWorkbooks(hwnd, ClassName, level, lHolder, lCnt, sFile)
'get the class name '------------------ sClassName = Space$(255) r = GetClassName(hwnd, sClassName, 255) sClassName = Left$(sClassName, r)
If sClassName Like ClassName & "*" Or sClassName = ClassName Then Referece2AllWorkbooks = hwnd lHolder = hwnd AccessibleObjectFromWindow hwnd, OBJID_NATIVEOM, IDispatch, oWnd If Not oWnd Is Nothing Then If oWnd.Visible Then lCnt = lCnt + 1 On Error Resume Next For Each wb In oWnd.Application.Workbooks wb.VBProject.References.AddFromFile sFile Next End If End If End If
А у меня так получилось. Следующий код нужно поместить в модуль ЭтаКнига надстройки. VBAProjectUserListBox заменить на имя вба-проекта надстройки (НЕ имя файла). При подключении надстройки, во все открытые книги проставляются ссылки на нее (и при открытии новых). При отключении - все ссылки убиваются. [vba]
Код
Private WithEvents App As Application Private pathXlam As String Private Sub Workbook_Open() Set App = Application Dim ref, Wbs As Workbook For Each ref In Application.VBE.VBProjects If ref.Name = "VBAProjectUserListBox" Then pathXlam = ref.Filename: Exit For Next ref
On Error Resume Next For Each Wbs In Workbooks Wbs.VBProject.References.AddFromFile pathXlam Next Wbs End Sub Private Sub Workbook_AddinUninstall() Dim ref, Wbs As Workbook For Each Wbs In Workbooks For Each ref In Wbs.VBProject.References If ref.Name = "VBAProjectUserListBox" Then Wbs.VBProject.References.Remove ref Next ref Next Wbs End Sub Private Sub App_WorkbookOpen(ByVal Wb As Workbook) On Error Resume Next Wb.VBProject.References.AddFromFile pathXlam End Sub Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) Dim ref For Each ref In Wb.VBProject.References If ref.Name = "VBAProjectUserListBox" Then Wb.VBProject.References.Remove ref Next ref End Sub
[/vba]
[p.s.]2003-го офиса у меня нет, проверяла только на 10-м[/p.s.]
А у меня так получилось. Следующий код нужно поместить в модуль ЭтаКнига надстройки. VBAProjectUserListBox заменить на имя вба-проекта надстройки (НЕ имя файла). При подключении надстройки, во все открытые книги проставляются ссылки на нее (и при открытии новых). При отключении - все ссылки убиваются. [vba]
Код
Private WithEvents App As Application Private pathXlam As String Private Sub Workbook_Open() Set App = Application Dim ref, Wbs As Workbook For Each ref In Application.VBE.VBProjects If ref.Name = "VBAProjectUserListBox" Then pathXlam = ref.Filename: Exit For Next ref
On Error Resume Next For Each Wbs In Workbooks Wbs.VBProject.References.AddFromFile pathXlam Next Wbs End Sub Private Sub Workbook_AddinUninstall() Dim ref, Wbs As Workbook For Each Wbs In Workbooks For Each ref In Wbs.VBProject.References If ref.Name = "VBAProjectUserListBox" Then Wbs.VBProject.References.Remove ref Next ref Next Wbs End Sub Private Sub App_WorkbookOpen(ByVal Wb As Workbook) On Error Resume Next Wb.VBProject.References.AddFromFile pathXlam End Sub Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) Dim ref For Each ref In Wb.VBProject.References If ref.Name = "VBAProjectUserListBox" Then Wb.VBProject.References.Remove ref Next ref End Sub
[/vba]
[p.s.]2003-го офиса у меня нет, проверяла только на 10-м[/p.s.]Manyasha
Подумал и решил, что автоматическое прописывание референса на не стандартную функцию - ЗЛО. Ведь если это сделать, то по привычке начнёшь применять LstBox точно так же на автомате как и MsgBox, а это при распространении написанного кода может привести к печальны последствиям. Уж лучше прежде чем применять чуть подумать и прописать референс ручками если код пишешь для себя или перекинуть программный модуль в новый проект, если планируешь его кому-нибудь отдать.
Подумал и решил, что автоматическое прописывание референса на не стандартную функцию - ЗЛО. Ведь если это сделать, то по привычке начнёшь применять LstBox точно так же на автомате как и MsgBox, а это при распространении написанного кода может привести к печальны последствиям. Уж лучше прежде чем применять чуть подумать и прописать референс ручками если код пишешь для себя или перекинуть программный модуль в новый проект, если планируешь его кому-нибудь отдать.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Суббота, 03.12.2016, 20:36