Private Sub Workbook_SheetActivate(ByVal Sh As Object) Dim d As Object Dim w#, h#, l#, t# If Selection.Cells.Count > 1 Then Exit Sub If Not IsNumeric(Sh.Name) Then 'если в имени листа цифра то 'рисуем кнопку For Each d In Sh.DrawingObjects If d.Name = "Kn" Then Exit Sub Next w = 695.75 'горизонталь l = 440.25 'вертикаль t = 85.25 'длина кнопки h = 50.25 'высота кнопки With Sh.Buttons.Add(w, l, t, h) .Caption = "Ok" .Name = "Kn" End With Sh.Cells(29, 13).Select End If End Sub
[/vba] Тут создается объект Buttons которому присвоено имя .Name = "Kn". Я проверяю по этому имени наличие либо отсутствие кнопки на открытом Листе, а вот, как обращаться к его свойствам: цвет, заливка и т.д.никак не пойму. Во втором примере кнопка отрисовывается при вызове функции: [vba]
Код
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim d As Object Dim w As Double Dim h As Double Dim l As Double Dim t As Double
'вызов функции Button_Add For Each sha In Sh.DrawingObjects If sha.Name = "ComButt" Then Exit Sub Next Button_Add Selection, vbGreen, "обработать данные"
End Sub
Public Function Button_Add(ByRef ra As Range, Optional ByVal ButtonColor As Long = 255, _ Optional ByVal ButtonName$ = "ComButt", Optional ByVal MacroName As String = "") 'функция рисует автофигуру поверх диапазона ra 'окрашивает созданную кнопку в цвет Button_color 'созданной кнопке назначаем макрос Расчет_выработки On Error Resume Next: Err.Clear
w = ra.Width: h = ra.Height: l = ra.Left: t = ra.Top
w = IIf(w >= 10, w, 50): h = IIf(h >= 10, h, 50) ' не создаем маленькие кнопки 10*10
' добавляем кнопку на лист Dim sha As Shape: Set sha = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, l, t, w, h) With sha ' оформляем автофигуру .Fill.Visible = msoTrue: .Fill.Solid .Fill.ForeColor.RGB = ButtonColor: .Fill.Transparency = 0.3 .Fill.BackColor.RGB = vbWhite .Fill.TwoColorGradient msoGradientFromCenter, 2 ' градиентная заливка .Adjustments.Item(1) = 0.23: .Placement = xlFreeFloating .OLEFormat.Object.PrintObject = False ' кнопки не выводятся на печать .Line.Weight = 0.25: .Line.ForeColor.RGB = vbBlack ' делаем тонкий черный контур With .TextFrame ' добавляем и форматируем текст .Characters.Text = ButtonName$ ' добавляем текст With .Characters.Font ' изменяем начертание текста .Size = IIf(h >= 16, 10, 8): .Bold = True: .Color = vbBlack: .Name = "Arial" ' цвет и шрифт End With .HorizontalAlignment = xlCenter: .VerticalAlignment = xlVAlignCenter End With .OnAction = MacroName ' назначаем кнопке макрос End With
End Function
[/vba] В функции Button_Add создается объект из коллекции Shape. И через .Fill я могу обращаться к его свойствам: цвет, заливка и т.д. Тут тоже пытаюсь провести проверку на наличие на активном Листе обЪекта по имени Optional ByVal ButtonName$ = "ComButt", но не получается. И еще один вопрос (пусть простят админы) по этому обЪекту. Точнее по расположению его. Делаю программу дома. Разрешение экрана свое. Принес на тест на работу. ОбЪект отрисовывается в другом месте. Вроде в институте когда делали работы на С++, вызывал функцию кажется свойств дисплея, и через эту функцию передавали расположение обЪектов. В своем случае хотел привязать координаты к определенным ячейкам. Например Range("L1:M2"). Но как сделать, не пойму. Делал так: [vba]
Код
ra.Left=Range("L1") ra.Top=Range("L1") w = ra.Width: h = ra.Height: l = ra.Left: t = ra.Top
[/vba] компилятор и не ругается, но все равно кнопка отрисовывает в месте щелчка.
Подскажите, как обратиться к обЪекту:
[vba]
Код
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Dim d As Object Dim w#, h#, l#, t# If Selection.Cells.Count > 1 Then Exit Sub If Not IsNumeric(Sh.Name) Then 'если в имени листа цифра то 'рисуем кнопку For Each d In Sh.DrawingObjects If d.Name = "Kn" Then Exit Sub Next w = 695.75 'горизонталь l = 440.25 'вертикаль t = 85.25 'длина кнопки h = 50.25 'высота кнопки With Sh.Buttons.Add(w, l, t, h) .Caption = "Ok" .Name = "Kn" End With Sh.Cells(29, 13).Select End If End Sub
[/vba] Тут создается объект Buttons которому присвоено имя .Name = "Kn". Я проверяю по этому имени наличие либо отсутствие кнопки на открытом Листе, а вот, как обращаться к его свойствам: цвет, заливка и т.д.никак не пойму. Во втором примере кнопка отрисовывается при вызове функции: [vba]
Код
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim d As Object Dim w As Double Dim h As Double Dim l As Double Dim t As Double
'вызов функции Button_Add For Each sha In Sh.DrawingObjects If sha.Name = "ComButt" Then Exit Sub Next Button_Add Selection, vbGreen, "обработать данные"
End Sub
Public Function Button_Add(ByRef ra As Range, Optional ByVal ButtonColor As Long = 255, _ Optional ByVal ButtonName$ = "ComButt", Optional ByVal MacroName As String = "") 'функция рисует автофигуру поверх диапазона ra 'окрашивает созданную кнопку в цвет Button_color 'созданной кнопке назначаем макрос Расчет_выработки On Error Resume Next: Err.Clear
w = ra.Width: h = ra.Height: l = ra.Left: t = ra.Top
w = IIf(w >= 10, w, 50): h = IIf(h >= 10, h, 50) ' не создаем маленькие кнопки 10*10
' добавляем кнопку на лист Dim sha As Shape: Set sha = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, l, t, w, h) With sha ' оформляем автофигуру .Fill.Visible = msoTrue: .Fill.Solid .Fill.ForeColor.RGB = ButtonColor: .Fill.Transparency = 0.3 .Fill.BackColor.RGB = vbWhite .Fill.TwoColorGradient msoGradientFromCenter, 2 ' градиентная заливка .Adjustments.Item(1) = 0.23: .Placement = xlFreeFloating .OLEFormat.Object.PrintObject = False ' кнопки не выводятся на печать .Line.Weight = 0.25: .Line.ForeColor.RGB = vbBlack ' делаем тонкий черный контур With .TextFrame ' добавляем и форматируем текст .Characters.Text = ButtonName$ ' добавляем текст With .Characters.Font ' изменяем начертание текста .Size = IIf(h >= 16, 10, 8): .Bold = True: .Color = vbBlack: .Name = "Arial" ' цвет и шрифт End With .HorizontalAlignment = xlCenter: .VerticalAlignment = xlVAlignCenter End With .OnAction = MacroName ' назначаем кнопке макрос End With
End Function
[/vba] В функции Button_Add создается объект из коллекции Shape. И через .Fill я могу обращаться к его свойствам: цвет, заливка и т.д. Тут тоже пытаюсь провести проверку на наличие на активном Листе обЪекта по имени Optional ByVal ButtonName$ = "ComButt", но не получается. И еще один вопрос (пусть простят админы) по этому обЪекту. Точнее по расположению его. Делаю программу дома. Разрешение экрана свое. Принес на тест на работу. ОбЪект отрисовывается в другом месте. Вроде в институте когда делали работы на С++, вызывал функцию кажется свойств дисплея, и через эту функцию передавали расположение обЪектов. В своем случае хотел привязать координаты к определенным ячейкам. Например Range("L1:M2"). Но как сделать, не пойму. Делал так: [vba]
Код
ra.Left=Range("L1") ra.Top=Range("L1") w = ra.Width: h = ra.Height: l = ra.Left: t = ra.Top
[/vba] компилятор и не ругается, но все равно кнопка отрисовывает в месте щелчка. Oleg34
- Прочитайте Правила форума - Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума
Админы, может, и простят, а вот модеры нет - п.4 Правил форума: один вопрос - одна тема
- Прочитайте Правила форума - Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума
Oleg34, Вы чудите. На Программерс задаете этот же вопрос, хотя он к теме не относится. Тут создаете тему с ним же не сообщая о кроспостинге. Так не стоит делать. На первый вопрос(попутно и на второй): В модуль книги: [vba]
Код
[vba][code]Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim d As Object Dim w As Double Dim h As Double Dim l As Double Dim t As Double 'вызов функции Button_Add If ShpExist("ComButt", Sh) Then Exit Sub Button_Add Sh.[d3], vbGreen, "обработать данные" End Sub
[/vba] В общий модуль: [vba]
Код
Function ShpExist(ShpName As String, Sh As Worksheet) As Boolean 'Возвращает ИСТИНА, если объект существует Dim x As Object On Error Resume Next Set x = Sh.Shapes(ShpName) ShpExist = (Err = 0) End Function Public Function Button_Add(ByRef ra As Range, Optional ByVal ButtonColor As Long = 255, _ Optional ByVal ButtonName$ = "ComButt", Optional ByVal MacroName As String = "") 'функция рисует автофигуру поверх диапазона ra 'окрашивает созданную кнопку в цвет Button_color 'созданной кнопке назначаем макрос Расчет_выработки Dim w&, h&, l&, t& On Error Resume Next: Err.Clear w = ra.Width: h = ra.Height: l = ra.Left: t = ra.Top w = IIf(w >= 10, w, 50): h = IIf(h >= 10, h, 50) ' не создаем маленькие кнопки 10*10 ' добавляем кнопку на лист Dim sha As Shape: Set sha = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, l, t, w, h) With sha ' оформляем автофигуру .Name = "ComButt" .Fill.Visible = msoTrue: .Fill.Solid .Fill.ForeColor.RGB = ButtonColor: .Fill.Transparency = 0.3 .Fill.BackColor.RGB = vbWhite .Fill.TwoColorGradient msoGradientFromCenter, 2 ' градиентная заливка .Adjustments.Item(1) = 0.23: .Placement = xlFreeFloating .OLEFormat.Object.PrintObject = False ' кнопки не выводятся на печать .Line.Weight = 0.25: .Line.ForeColor.RGB = vbBlack ' делаем тонкий черный контур With .TextFrame ' добавляем и форматируем текст .Characters.Text = ButtonName$ ' добавляем текст With .Characters.Font ' изменяем начертание текста .Size = IIf(h >= 16, 10, 8): .Bold = True: .Color = vbBlack: .Name = "Arial" ' цвет и шрифт End With .HorizontalAlignment = xlCenter: .VerticalAlignment = xlVAlignCenter End With .OnAction = MacroName ' назначаем кнопке макрос End With End Function
[/vba]
Oleg34, Вы чудите. На Программерс задаете этот же вопрос, хотя он к теме не относится. Тут создаете тему с ним же не сообщая о кроспостинге. Так не стоит делать. На первый вопрос(попутно и на второй): В модуль книги: [vba]
Код
[vba][code]Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim d As Object Dim w As Double Dim h As Double Dim l As Double Dim t As Double 'вызов функции Button_Add If ShpExist("ComButt", Sh) Then Exit Sub Button_Add Sh.[d3], vbGreen, "обработать данные" End Sub
[/vba] В общий модуль: [vba]
Код
Function ShpExist(ShpName As String, Sh As Worksheet) As Boolean 'Возвращает ИСТИНА, если объект существует Dim x As Object On Error Resume Next Set x = Sh.Shapes(ShpName) ShpExist = (Err = 0) End Function Public Function Button_Add(ByRef ra As Range, Optional ByVal ButtonColor As Long = 255, _ Optional ByVal ButtonName$ = "ComButt", Optional ByVal MacroName As String = "") 'функция рисует автофигуру поверх диапазона ra 'окрашивает созданную кнопку в цвет Button_color 'созданной кнопке назначаем макрос Расчет_выработки Dim w&, h&, l&, t& On Error Resume Next: Err.Clear w = ra.Width: h = ra.Height: l = ra.Left: t = ra.Top w = IIf(w >= 10, w, 50): h = IIf(h >= 10, h, 50) ' не создаем маленькие кнопки 10*10 ' добавляем кнопку на лист Dim sha As Shape: Set sha = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, l, t, w, h) With sha ' оформляем автофигуру .Name = "ComButt" .Fill.Visible = msoTrue: .Fill.Solid .Fill.ForeColor.RGB = ButtonColor: .Fill.Transparency = 0.3 .Fill.BackColor.RGB = vbWhite .Fill.TwoColorGradient msoGradientFromCenter, 2 ' градиентная заливка .Adjustments.Item(1) = 0.23: .Placement = xlFreeFloating .OLEFormat.Object.PrintObject = False ' кнопки не выводятся на печать .Line.Weight = 0.25: .Line.ForeColor.RGB = vbBlack ' делаем тонкий черный контур With .TextFrame ' добавляем и форматируем текст .Characters.Text = ButtonName$ ' добавляем текст With .Characters.Font ' изменяем начертание текста .Size = IIf(h >= 16, 10, 8): .Bold = True: .Color = vbBlack: .Name = "Arial" ' цвет и шрифт End With .HorizontalAlignment = xlCenter: .VerticalAlignment = xlVAlignCenter End With .OnAction = MacroName ' назначаем кнопке макрос End With End Function
[offtop]Потому и не помог, что вопрос не по теме и Вы обращались ко мне конкретно. Воспитанные люди не лезут в чужие разговоры. Хотите помощи от форума - обращайтесь к форуму.[/offtop]
[offtop]Потому и не помог, что вопрос не по теме и Вы обращались ко мне конкретно. Воспитанные люди не лезут в чужие разговоры. Хотите помощи от форума - обращайтесь к форуму.[/offtop]KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728