Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Ağustos 2007 Çarşamba

Create Program Menu at UserForm




'UserForm1

'A) VBProject References List

'Visual Basic For Applications
'Microsoft Excel 11.0 Object Library
'Microsoft Forms 2.0 Object Library
'Microsoft Office 11.0 Object Library
'OLE Automation
'Microsoft Windows Common Controls 6.0 (SP6)
'B) Addition Tools on UserForm1
'Image1
Option Explicit
Private AçMenü1 As Office.CommandBar
Private Komut1 As Office.CommandBarButton
Private Eleman As Worksheet
Private Sub UserForm_Initialize()

On Error Resume Next
Call EkranDüzenle
Set Bezeme.SimgeYerleştir = Me
FormGörevi = FindWindow(vbNullString, Me.Caption)
Call BaşlamaDüğmesi
'StartButton
Call KısaYolDüğmesi
'ShortCutButton
Call MenüDüzenle
MenüBant = SetWindowLong(FormGörevi, (-4), AddressOf MenüKanca)
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
Set Bezeme.Ekran2 = Me
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
End Sub
Private Sub UserForm_Terminate()

On Error Resume Next
On Error GoTo 0
DestroyMenu MenüGörevi
SetWindowLong FormGörevi, (-4), MenüBant
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
If Button = 2 Then
Set AçMenü1 = Application.CommandBars.Add("", msoBarPopup, , True)
Set Komut1 = AçMenü1.Controls.Add(1, , , , True)
With Komut1
.Caption = "Komut1"
.Enabled = True
.OnAction = "Makro2"
.FaceID = 66
End With
AçMenü1.ShowPopup
AçMenü1.Delete
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Application.Visible = True
DestroyMenu MenüGörevi
SetWindowLong FormGörevi, (-4), MenüBant
End Sub
Private Sub EkranDüzenle()

On Error Resume Next
Application.Visible = False
With Me
.Caption = " [PBİD ®] Create Program Menu at UserForm"
.BackColor = vbWhite
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeZoom
With .Image1
.AutoSize = True :.Visible= False
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\Blogspot\Örnekİkonlar\PBİD.ico")
End With
End With
Call MenüSayfasıDüzenle
'Menü sayfası kullanıcı tarafından düzenlendiğinde bu makro iptal edilir
End Sub
Private Sub MenüSayfasıDüzenle()

On Error Resume Next
For Each Eleman In ThisWorkbook.Worksheets
If Eleman.Name = "Menü" Then GoTo Devam
Next Eleman
ThisWorkbook.Worksheets.Add Before:=Sheets(1)
Application.ActiveSheet.Name = "Menü"
Devam:
Sheets("Menü").Select
Range("A1").FormulaR1C1 = "Seviye"
Range("B1").FormulaR1C1 = "Menü Adı"
Range("C1").FormulaR1C1 = "Makro No"
Range("D1").FormulaR1C1 = "Resim No"
Range("E1").FormulaR1C1 = "Kök ID"
Range("F1").FormulaR1C1 = "Dal Sayısı"
Range("G1").FormulaR1C1 = "Etkinlik"
Range("A1:G1").Select
Selection.Font.ColorIndex = 2
With Selection.Interior
.ColorIndex = 5
.Pattern = xlSolid
End With
Selection.Font.Bold = False
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").FormulaR1C1 = "1"
Range("A3").FormulaR1C1 = "2"
Range("A4").FormulaR1C1 = "2"
Range("A5").FormulaR1C1 = "3"
Range("A6").FormulaR1C1 = "3"
Range("A7").FormulaR1C1 = "3"
Range("A8").FormulaR1C1 = "3"
Range("A9").FormulaR1C1 = "3"
Range("A10").FormulaR1C1 = "1"
Range("A11").FormulaR1C1 = "2"
Range("A12").FormulaR1C1 = "2"
Range("A13").FormulaR1C1 = "3"
Range("A14").FormulaR1C1 = "3"
Range("A15").FormulaR1C1 = "3"
Range("A16").FormulaR1C1 = "3"
Range("A17").FormulaR1C1 = "3"
Range("A18").FormulaR1C1 = "4"
Range("A19").FormulaR1C1 = "4"
Range("A20").FormulaR1C1 = "5"
Range("A21").FormulaR1C1 = "5"
Range("A22").FormulaR1C1 = "6"
Range("A23").FormulaR1C1 = "6"
Range("A24").FormulaR1C1 = "7"
Range("B2").FormulaR1C1 = "Menü1"
Range("B3").FormulaR1C1 = "Menü1.1"
Range("B4").FormulaR1C1 = "Menü1.2"
Range("B5").FormulaR1C1 = "Menü1.2.1"
Range("B6").FormulaR1C1 = "Menü1.2.2"
Range("B7").FormulaR1C1 = "Menü1.2.3"
Range("B8").FormulaR1C1 = "Menü1.2.4"
Range("B9").FormulaR1C1 = "Menü1.2.5"
Range("B10").FormulaR1C1 = "Menü2"
Range("B11").FormulaR1C1 = "Menü2.1"
Range("B12").FormulaR1C1 = "Menü2.2"
Range("B13").FormulaR1C1 = "Menü2.2.1"
Range("B14").FormulaR1C1 = "Menü2.2.2"
Range("B15").FormulaR1C1 = "Menü2.2.3"
Range("B16").FormulaR1C1 = "Menü2.2.4"
Range("B17").FormulaR1C1 = "Menü2.2.5"
Range("B18").FormulaR1C1 = "Menü2.2.5.1"
Range("B19").FormulaR1C1 = "Menü2.2.5.2"
Range("B20").FormulaR1C1 = "Menü2.2.5.2.1"
Range("B21").FormulaR1C1 = "Menü2.2.5.2.2"
Range("B22").FormulaR1C1 = "Menü2.2.5.2.2.1"
Range("B23").FormulaR1C1 = "Menü2.2.5.2.2.2"
Range("B24").FormulaR1C1 = "Menü2.2.5.2.2.2.1"
Range("C2").ClearContents
Range("C3").FormulaR1C1 = "1"
Range("C4").ClearContents
Range("C5").FormulaR1C1 = "2"
Range("C6").FormulaR1C1 = "3"
Range("C7").FormulaR1C1 = "4"
Range("C8").FormulaR1C1 = "5"
Range("C9").FormulaR1C1 = "6"
Range("C10").ClearContents
Range("C11").FormulaR1C1 = "7"
Range("C12").ClearContents
Range("C13").FormulaR1C1 = "8"
Range("C14").FormulaR1C1 = "9"
Range("C15").FormulaR1C1 = "10"
Range("C16").FormulaR1C1 = "11"
Range("C17").FormulaR1C1 = "12"
Range("C18:C24").ClearContents
Range("D2").ClearContents
Range("D3").FormulaR1C1 = "400"
Range("D5").FormulaR1C1 = "401"
Range("D6").FormulaR1C1 = "402"
Range("D7").FormulaR1C1 = "403"
Range("D8").FormulaR1C1 = "404"
Range("D9").FormulaR1C1 = "405"
Range("D10").ClearContents
Range("D11").FormulaR1C1 = "406"
Range("D12").ClearContents
Range("D13").FormulaR1C1 = "407"
Range("D14").FormulaR1C1 = "408"
Range("D15").FormulaR1C1 = "409"
Range("D16").FormulaR1C1 = "410"
Range("D17").FormulaR1C1 = "411"
Range("D18:D23").ClearContents
Range("D24").FormulaR1C1 = "412"
Range("E2:G24").ClearContents
Range("G2:G24").FormulaR1C1 = "TRUE"
End Sub

'Module1

'Ekran (System Menu) Düzenleme

Option Explicit
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetActiveWindow Lib "user32.dll" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Public Bezeme As New Class1
Public Pencere As Long, Simge As Long, MenüGörevi As Long, FormGörevi As Long
Public X, Y As Integer
Public i, ii, iii As Single

'Module2

'UserForm (UserMenu)Kullanıcı Menüsü

Option Explicit
Public Declare Function CreateMenu Lib "user32" () As Long
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nposition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private AçMenü1 As Office.CommandBar
Private Komut As Office.CommandBarButton
Private SeçilenResim(1000) As New Image
Private Katalog As New ImageList
Private KomutSeçimi As Long
Private Seviye As Double
Private ID As Variant
Private Dal As Double
Private KökID As Variant
Private Adı As String
Private Makro As Double
Private Resim As Variant
Private Sayfa As Worksheet
Private Adet As Double
Public Sub MenüDüzenle()

On Error Resume Next
Set Sayfa = ThisWorkbook.Sheets("Menü")
Adet = Application.WorksheetFunction.Count(Sayfa.Range("A2:A65536"))
MenüGörevi = CreateMenu()
KomutSeçimi = SetMenu(FormGörevi, MenüGörevi)
Sayfa.Range("E2:F600").ClearContents
For i = 1 To Adet
Seviye = Sayfa.Cells(i + 1, 1).Value
Adı = Sayfa.Cells(i + 1, 2).Value
ID = Adı
Makro = Sayfa.Cells(i + 1, 3).Value
Resim = Sayfa.Cells(i + 1, 4).Value
If Seviye = 1 Then
If Makro = 0 Then
ID = CreateMenu()
Sayfa.Cells(i + 1, 5).Value = ID
AppendMenu MenüGörevi, &H10, ID, Adı
Else
ID = CreateMenu()
Sayfa.Cells(i + 1, 5).Value = ID
If Sayfa.Cells(i + 1, 7).Value = True Then

AppendMenu MenüGörevi, &H0, Makro, Adı
Else
AppendMenu MenüGörevi, &H1, Makro, Adı
End If
End If
Else
If Sayfa.Cells(i + 1 + 1, 1).Value > Seviye Then
For ii = 1 To (i - 1)
If Sayfa.Cells(i + 1 - ii, 1).Value = Seviye - 1 Then
KökID = Sayfa.Cells(i + 1 - ii, 5).Value
Exit For
End If
Next ii
ID = CreateMenu()
Sayfa.Cells(i + 1, 5).Value = ID
Sayfa.Cells(i + 1 - ii, 6).Value = Sayfa.Cells(i + 1 - ii, 6).Value + 1
If Adı <> "" Then
AppendMenu KökID, &H10, ID, Adı
Else
AppendMenu KökID, &H800&, 0, ""
End If
Else
For ii = 1 To (i - 1)
If Sayfa.Cells(i + 1 - ii, 1).Value = Seviye - 1 Then
KökID = Sayfa.Cells(i + 1 - ii, 5).Value
Exit For
End If
Next ii
Sayfa.Cells(i + 1 - ii, 6).Value = Sayfa.Cells(i + 1 - ii, 6).Value + 1
If Adı <> "" Then
Dal = Sayfa.Cells(i + 1 - ii, 6).Value
If Sayfa.Cells(i + 1, 7).Value = True Then
AppendMenu KökID, &H0, Makro, Adı
Else
AppendMenu KökID, &H1, Makro, Adı
End If
Call ResimBul
With SeçilenResim(i)
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Enabled = True
.PictureAlignment = fmPictureAlignmentCenter
.SpecialEffect = fmSpecialEffectFlat
.PictureSizeMode = fmPictureSizeModeStretch
End With
SetMenuItemBitmaps KökID, (Dal - 1), &H400&, SeçilenResim(i).Picture, SeçilenResim(i).Picture
Else
AppendMenu KökID, &H800&, 0, ""
End If
End If
End If
Next i
End Sub
Sub ResimBul()

On Error Resume Next
Set AçMenü1 = Application.CommandBars.Add("", msoBarPopup, , True)
Set Komut = AçMenü1.Controls.Add(1, , , , True)
Komut.FaceID = Resim
SeçilenResim(i).Picture = Komut.Picture
AçMenü1.Delete
End Sub

'Module3

'Menü Yakalama
Option Explicit
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public MenüBant As Long
Public Const MenüSeçim As Long = &H111
Public Function MenüKanca(ByVal Pencere As Long, ByVal Seçim As Long, ByVal wSeçenek As Long, ByVal lSeçenek As Long) As Long

On Error Resume Next
If Seçim = MenüSeçim Then
DoEvents
Select Case wSeçenek
Case 1: Call Makro1
Case 2: Call Makro2
Case 3: Call Makro3
Case 4: Call Makro4
Case 5: Call Makro5
Case 6: Call Makro6
Case 7: Call Makro1
Case 8: Call Makro2
Case 9: Call Makro3
Case 10: Call Makro4
Case 11: Call Makro5
Case 12: Call Makro6
End Select
End If
MenüKanca = CallWindowProc(MenüBant, Pencere, Seçim, wSeçenek, lSeçenek)
End Function
Sub Makro1()

End Sub
Sub Makro2()

End Sub
Sub Makro3()

End Sub
Sub Makro4()

End Sub
Sub Makro5()

End Sub
Sub Makro6()

End Sub
Sub Makro7()

End Sub
Sub Makro8()

End Sub
Sub Makro9()

End Sub
Sub Makro10()

End Sub
Sub Makro11()

End Sub
Sub Makro12()

End Sub


'Module4

'Başlama (Start Button) Düğmesini Değiştirme


Option Explicit
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As Dörtgen) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Type Dörtgen

     DSol As Long
     DÜst As Long
     DSağ As Long
     DAlt As Long

End Type
Public B32D As Dörtgen, BB As Dörtgen, BD As Dörtgen
Public BR() As Byte, BA() As Byte
Public BM As String
Public Boy As Integer
Public BSonuç As Long, B32P As Long, BYB As Long, B32E As Long, BDP As Long
Sub BaşlamaDüğmesi()

On Error Resume Next
BM = "PBİD ®"
Boy = VBA.Len(BM)
ReDim BR(VBA.Len(BM) + 1)
ReDim BA(Boy)
For X = 0 To Boy - 1
BA(X) = Asc(VBA.Mid(BM, X + 1, 1))
Next X
BA(Boy) = 0
BR = BA
BSonuç = GetWindowRect(FindWindow("Shell_TrayWnd", ""), BD)
B32P = FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0, "ReBarWindow32", "")
BSonuç = GetWindowRect(B32P, B32D)
BSonuç = GetWindowRect(FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0, "TrayNotifyWnd", ""), BB)
BYB = VBA.Len(BM) * (99 / 5)
B32E = (BD.DSağ - BD.DSol) - (BB.DSağ - BB.DSol) - BYB
BDP = GetWindow(FindWindow("Shell_TrayWnd", ""), 5)
SendMessage BDP, &HC, 0, BR(0)
Call SetWindowPos(B32P, 0, BYB + 5, 0, B32E, (BD.DAlt - BD.DÜst), &H40)
Call SetWindowPos(BDP, 0, 0, 0, BYB, 32, &H40)
End Sub

'Module5

'Başlama Menüsüne Start Menu ShortCut Button) Kısa Yol Düğmesi Ekleme
Option Explicit
Dim Yol As String, KısaYol As String, MevcutYol As String
Dim İkon As Object, İkonYol As Object
Sub KısaYolDüğmesi()

On Error Resume Next
MevcutYol = ThisWorkbook.Path
Set İkon = VBA.CreateObject("Wscript.Shell")
Yol = İkon.SpecialFolders("Programs")
VBA.MkDir Yol & "\PBİD"
KısaYol = Yol & "\PBİD" & "\" & "PBİD.lnk"
Set İkonYol = İkon.CreateShortcut(KısaYol)
With İkonYol
.TargetPath = MevcutYol & "\UserFormCBMenu.xls"
.Description = "PBİD ® Program Bütçeleme ve İzleme Değerlendirme"
.IconLocation = MevcutYol & "\Örnekİkonlar\PBİD.ico"
.RelativePath = MevcutYol
.WorkingDirectory = MevcutYol
.Hotkey = "Ctrl+Alt+p"
.Save
End With
Set İkon = Nothing
End Sub

'Class1

Option Explicit
Dim Netice As Long
Public Property Set SimgeYerleştir(Ekran As Object)

On Error Resume Next
Simge = Ekran.Image1.Picture
Call SendMessage(FindWindow(vbNullString, Ekran.Caption), &H80, 0&, ByVal Simge)
Call SendMessage(FindWindow(vbNullString, Ekran.Caption), &H80, 1&, ByVal Simge)
End Property
Public Property Set Ekran1(Ekran As Object)
'[+,+,+]Büyük Açar

On Error Resume Next
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-16), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-16)) Or &H80000 Or &H20000 Or &H10000
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
ShowWindow FindWindow(vbNullString, Ekran.Caption), 3
SetFocus FindWindow(vbNullString, Ekran.Caption)
End Property
Public Property Set Ekran2(Ekran As Object)
'[+,+,+]Küçük Açar

On Error Resume Next
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-16), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-16)) Or &H80000 Or &H20000 Or &H10000
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
ShowWindow FindWindow(vbNullString, Ekran.Caption), 5
SetFocus FindWindow(vbNullString, Ekran.Caption)
EkranTipi Ekran
End Property
Function EkranTipi(Ekran As Object)

On Error Resume Next
If Application.Version >= 9 Then
Netice = FindWindow("ThunderDFrame", Ekran.Caption)
Else
Netice = FindWindow("ThunderXFrame", Ekran.Caption)
End If
Pencere = GetWindowLong(Netice, -16)
If (Pencere And &H30000) = 0 Then
SetWindowLong Pencere, -16, Pencere Or &H30000
Set Bezeme.Ekran2 = Me
End If
End Function

'Workbook Module

Private Sub Workbook_Open()
           On Error Resume Next
           UserForm1.Show

End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul