Yeni olusturulan menu hakkında

[Kemal Demir]

Günaydın arkadaşlar,

    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=23
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=106
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=3
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=19
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=21
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=852
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=1957
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=1589
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=1576
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=308
    Application.CommandBars("Custom Popup 3845812").Controls.Add Type:=msoControlButton, ID:=2915

Olusturmak istediğim menuler excel'in halihazırda kullandıgı menulerden karma bir menu ( surekli kullandıgım ) olusturmayı dusunuyorum.

Macro Recorder ( kaydedici ) ile bu kontrollerin ıd'lerini bulabildim.Boyle bir menu olusturmada yardımcı olabilirseniz sevinirim.
Kendi olustudugum menu bazen creat etmiyor.

Bunun için kullandıgınız yada çözümüm için bir kod örneğiniz varsa paylaşabilirmisiniz.

İyi çalışmalar.

 

[uzmanamele]

merhaba
syn Rakkas;
menü kodları ile ilgili eksik bir çalışmam vardı, ID kodlarının listesi var, siz tamamlarsınız artık.
ekdeki dosyalar işinize yarayabilir.

 

[Haluk]

Merhaba;

Bu da benim eski bir çalışmam...

Sub CommandBarControls()
    'Raider ®
    Dim Start As Long, Finnish As Long, ElapsedTime As Long
    Dim i As Integer, j As Integer, No As Integer
    Dim CtrlID As Long
    Dim MySh As Worksheet, IndexSh As Worksheet
    
    Start = Timer
    On Error Resume Next
    Set MySh = Worksheets.Add
    MySh.Name = "CommandBars"
    
    For k = 1 To Application.CommandBars.Count
     MySh.Cells(k, 1) = Application.CommandBars(k).Name
    Next k
    
    For i = 1 To Application.CommandBars.Count
        Set MySh = Worksheets.Add
        Set MyCmdBar = Application.CommandBars(i)
        No = No + 1
        MySh.Name = Application.CommandBars(i).Name
        
            With MySh
                .Range("B1") = UCase(MySh.Name)
                .Range("A2") = "Etiket"
                .Range("B2") = "Control ID"
                .Range("C2") = "Face"
                .Range("D2") = "CommandBars sayfasına dönüş !"
                .Range("A1:D2").Font.Bold = True
                .Range("A1:C2").Font.Color = vbRed
                .Range("A1:C2").Font.Size = 12
                .Range("B1").Font.Color = vbBlack
                .Hyperlinks.Add Anchor:=.Range("D2"), Address:="", _
                                         SubAddress:="'CommandBars'!A1"
            End With
            
            For j = 3 To MyCmdBar.Controls.Count
                MySh.Cells(j, 1) = MyCmdBar.Controls(j).Caption
                CtrlID = MyCmdBar.Controls(j).ID
                MySh.Cells(j, 2) = CtrlID
                Set MyControl = MyCmdBar.FindControl(Type:=msoControlButton, ID:=CtrlID)
                MyControl.CopyFace
                MySh.Paste Destination:=MySh.Cells(j, 3)
                MySh.Columns("A:D").AutoFit
            Next j
    Next i
    
    Set IndexSh = Worksheets("CommandBars")
    
    For i = 1 To IndexSh.Cells(65536, 1).End(xlUp).Row
        ActiveSheet.Hyperlinks.Add Anchor:=IndexSh.Cells(i, 1), _
        Address:="", SubAddress:="'" & IndexSh.Cells(i, 1).Text & "'!A1", _
        TextToDisplay:=IndexSh.Cells(i, 1).Text
    Next i
    
    IndexSh.Activate
    IndexSh.Columns("A:A").AutoFit
    Finnish = Timer
    ElapsedTime = Finnish - Start
    MsgBox "Excel'in menülerindeki ve araç çubuklarındaki kontroller " _
    & vbCrLf & Int(ElapsedTime) & " saniyede sayfalara işlenmiştir !" _
    & vbCrLf & vbCrLf _
    & "Bu iş için toplam : " & No + 1 & " adet sayfa, " _
    & "bu XL dosyasına ilave edilmiştir.", vbInformation, "Rapor !"
    Set IndexSh = Nothing
    Set MyControl = Nothing
    Set MyCmdBar = Nothing
    Set MySh = Nothing
End Sub

 

[Haluk]

Bu da başka bir çalışmam...

    'Haluk ® - 17/02/2006
    Sub CommandBarControlID()
        Dim Header1 As String * 5
        Dim Header2 As String * 38
        Dim Header3 As String * 10
        Dim Capt As String * 30
        Dim WinScrObj As Object, MyShortCut As Object
        Dim MyFolder As String, MyFile As String
        Dim TargPath As String

        TargPath = "C:\MS-ExcelControlsID.txt"
        MyFile = "MS-ExcelControlsID.txt"
       
        Header1 = "No"
        Header2 = "Kontrol"
        Header3 = "ID"
            Open TargPath For Output As #1
            Print #1, Header1; Header2; Header3
            Print #1, String(50, "-")
            Print #1,
                For Each Ctrl In CommandBars.FindControls
                    i = i + 1
                    Capt = Replace(Ctrl.Caption, "&", "")
                    CtrlId = Ctrl.ID
                    Print #1, i & ") "; Capt, CtrlId
                Next
            Close #1
           
        Set WinScrObj = CreateObject("WScript.Shell")
        MyFolder = WinScrObj.SpecialFolders("DeskTop")
        Set MyShortCut = WinScrObj.CreateShortcut _
                        (MyFolder & "\" & MyFile & ".lnk")
        With MyShortCut
            .TargetPath = WinScrObj.ExpandEnvironmentStrings(TargPath)
            .WorkingDirectory = WinScrObj.ExpandEnvironmentStrings(TargPath)
            .WindowStyle = 4
            .IconLocation = WinScrObj.ExpandEnvironmentStrings(TargPath & ", 0")
            .Save
        End With
       
        MsgBox "Masaustune dosya icin kisa yol olusturuldu ...", vbInformation, "Rapor !"
        Set WinScrObj = Nothing
        Set MyShortCut = Nothing
    End Sub

 

[Kemal Demir]

Arkadaşlar, teşekkurler

En kısa zamanda deneyeceğim.

İlginizden dolayı teşekkurler.