Idézet: monamee - Dátum: 2012. 01. 09. 20:36
Más megoldást nem tudsz?
Köszi
a szerkesztő előtt ott láthatod a név mezőt. Ird be: A65536. Nyomd le: Shift+Ctrl+End...
Mellékleteink: HUP | Gamekapocs
Elküldve: 2012. 01. 13. 21:26
Elküldve: 2012. 01. 20. 10:14
Elküldve: 2012. 02. 15. 16:05
Elküldve: 2012. 02. 16. 13:46
Elküldve: 2012. 02. 22. 08:52
Elküldve: 2012. 02. 22. 09:06
Elküldve: 2012. 02. 22. 09:10
Idézet: Delila - Dátum: 2012. 02. 22. 09:06
Elküldve: 2012. 02. 28. 18:48
Elküldve: 2012. 03. 01. 15:31
Idézet: sutemeny - Dátum: 2012. 02. 28. 18:48
Elküldve: 2012. 03. 01. 20:25
Elküldve: 2012. 03. 28. 14:25
Szerkesztette: hkpk 2012. 03. 28. 14:30 -kor
Elküldve: 2012. 03. 28. 14:35
Elküldve: 2012. 03. 29. 08:14
Idézet: Delila - Dátum: 2012. 03. 28. 15:35
Szerkesztette: hkpk 2012. 03. 29. 08:16 -kor
Elküldve: 2012. 03. 30. 09:18
Idézet: Delila - Dátum: 2012. 03. 28. 15:35
Option Explicit
Sub gombAzonosító()
Dim newBar As Object
Dim Con As Object
Dim I As Long
Dim K As Long
Dim Felirat As String
Application.ScreenUpdating = False
On Error GoTo hiba
I = 1
Set newBar = CommandBars.Add(Name:="Custom2", _
Position:=msoBarTop, Temporary:=True)
newBar.Visible = True
'Meddig számoljon
For K = 1 To 8000
Set Con = newBar.Controls.Add(Type:=msoControlButton, Id:=K)
Cells(I, 1) = Str(Con.Id)
Cells(I, 1 + 1) = Con.Caption
Cells(I, 1 + 2).Select
Con.CopyFace
ActiveSheet.Paste
Con.Delete
I = I + 1
Tovabb:
Next K
CommandBars("Custom2").Delete
Columns(2).EntireColumn.AutoFit
Exit Sub
hiba:
Resume Tovabb
End Sub
'Meglévő "Saját menüpontom" menü törlése az új létrehozása előtt
Dim sormenu As Object
For Each menusor In Application.CommandBars()
menuneve = menusor.Name
If menuneve = "Worksheet Menu Bar" Then
Set sormenu = Application.CommandBars(menuneve)
For Each menupont In sormenu.Controls()
If menupont.Caption = "S&aját menüpontom" Then
menupont.Delete
exit for
End If
Next menupont
End If
Next menusor
epit:
'"Saját menüpontom" menüpont létrehozása:
Dim Menu1 As Object
Set Menu1 = sormenu.Controls.Add(Type:=msoControlPopup)
Menu1.Caption = "S&aját menüpontom"
'Almenük létrehozása a "Saját menüpontom" menüponthoz:
Set subMenu1 = Menu1.Controls.Add(Type:=msoControlButton)
With subMenu1
.Style = msobuttonandicon
.OnAction = "Bővítmény.XLA!X_filebeolvas"
.Caption = "Mega &NX*.TX* lista..."
End With
End If
Set subMenu2 = Menu1.Controls.Add(Type:=msoControlButton)
With subMenu2
.Style = msobuttonandicon
.OnAction = "Bővítmény.XLA!A_filebeolvas"
.Caption = "&Alap bit-TXT lista..."
.FaceId = 53 ' <- Ikon hozzárendelése a menüponthoz
End With
End If
'Stb...
Sub AddNewCB()
Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
On Error GoTo AddNewCB_Err
Set myCommandBar = CommandBars.Add(Name:="Sample Toolbar", Position:= _
msoBarFloating)
myCommandBar.Visible = True
Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
With myCommandBarCtl
.FaceId = 17 <-Ikon hozzárendelése
.Caption = "Toggle Button"
.TooltipText = "Toggle First Button"
.OnAction = "=ToggleButton()"
End With
Exit Sub
AddNewCB_Err:
MsgBox "Error " & Err.Number & vbCr & Err.Description
Exit Sub
'Ezt futtatja a nyomógomb:
Function ToggleButton()
Dim CBButton As CommandBarControl
On Error GoTo ToggleButton_Err
Set CBButton = CommandBars("Sample Toolbar").Controls(1)
CBButton.Visible = Not CBButton.Visible
Exit Function
ToggleButton_Err:
MsgBox "Error " & Err.Number & vbCr & Err.Description
Exit Function
End Function
End Sub
Sub AddNewMB2()
Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
Dim myCommandBarSubCtl As CommandBarControl
On Error GoTo AddNewMB_Err
Set myCommandBar = CommandBars.Add(Name:="Sample Menu Bar", Position:= _
msoBarTop, MenuBar:=True, Temporary:=False)
'Set myCommandBar = CommandBars.Add(Name:="Sample Menu Bar", _
MenuBar:=True, Temporary:=False)
myCommandBar.Visible = True
'myCommandBar.Protection = msoBarNoMove
Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlPopup)
myCommandBarCtl.Caption = "Displa&y"
Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton)
With myCommandBarSubCtl
.Style = msoButtonIconAndCaption
.Caption = "E&nable ClickMe"
.FaceId = 59
.OnAction = "=ToggleClickMe()"
.Parameter = 1
.BeginGroup = True
End With
Exit Sub
AddNewMB_Err:
MsgBox "Error " & Err.Number & vbCr & Err.Description
End Sub
Function ToggleClickMe()
Dim MyMenu As CommandBar
Dim myCommandBarClickMe As CommandBarControl
On Error GoTo ToggleClickMe_Err
Set MyMenu = CommandBars("Sample Menu Bar")
Set myCommandBarClickMe = MyMenu.Controls(2)
With CommandBars.ActionControl
Select Case .Parameter
Case 1
myCommandBarClickMe.Enabled = True
Case 2
myCommandBarClickMe.Enabled = False
End Select
End With
Exit Function
ToggleClickMe_Err:
MsgBox "Error " & Err.Number & vbCr & Err.Description
Exit Function
End Function
Sub AddNewMB()
Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
Dim myCommandBarSubCtl As CommandBarControl
On Error GoTo AddNewMB_Err
Set myCommandBar = CommandBars.Add(Name:="Sample Menu Bar", Position:= _
msoBarTop, MenuBar:=True, Temporary:=False)
myCommandBar.Visible = True
myCommandBar.Protection = msoBarNoMove
Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlPopup)
myCommandBarCtl.Caption = "Displa&y"
Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton)
With myCommandBarSubCtl
.Style = msoButtonIconAndCaption
.Caption = "E&nable ClickMe"
.FaceId = 59
.OnAction = "=MsgBox(""You clicked Enable ClickMe"")"
.Parameter = 1
.BeginGroup = True
End With
Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton)
With myCommandBarSubCtl
.Style = msoButtonIconAndCaption
.Caption = "Di&sable ClickMe"
.FaceId = 276
.OnAction = "=MsgBox(""You Disable ClickMe"")"
.Parameter = 2
.BeginGroup = True
End With
Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
With myCommandBarCtl
.BeginGroup = True
.Caption = "&ClickMe"
.Style = msoButtonCaption
.OnAction = "=MsgBox(""You clicked ClickMe"")"
End With
Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
With myCommandBarCtl
.BeginGroup = True
.Caption = "&Set Visibility Off"
.Style = msoButtonCaption
.OnAction = "=MsgBox(""You set visibility off"")"
End With
Exit Sub
AddNewMB_Err:
MsgBox "Error " & Err.Number & vbCr & Err.Description
Exit Sub
End Sub
Elküldve: 2012. 03. 30. 12:50
Elküldve: 2012. 03. 31. 17:17
Elküldve: 2012. 03. 31. 20:34
Idézet: Delila - Dátum: 2012. 03. 31. 19:46