Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Eylül 2003 Çarşamba

Private PopUp Menus On The Page 04




'Module1

Option Explicit
Dim i As Single, ii As Single, No As Single, Adet As Double
Type HücreBilgisi

HücreVerisi As Variant
HücreAdresi As String

End Type
Public WB As Workbook, WS As Worksheet, Hücre() As HücreBilgisi, Alan As Range
Dim Durum As Boolean
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private 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
Const Gizle = &H80
Const Goster = &H40
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_CONTROL = &H11
Const KEYEVENTF_KEYUP = &H2
Const VK_ESCAPE = &H1B
Sub Auto_Open()

On Error Resume Next
Application.DisplayAlerts = False
Application.EnableCancelKey = xlDisabled
Application.CommandBars("Cell").Reset
With ShortcutMenus(xlWorksheetCell)
.MenuItems.AddMenu "Sayfa Özel Komutları [Page Special Commands]", 1
With .MenuItems("Sayfa Özel Komutları [Page Special Commands]")
.MenuItems.Add "Geri Almaya Duyarlı İşlem [Sensitive Transaction Rollback]", OnAction:="GeriAlmayaDuyarlıİşlem"
.MenuItems.Add "İşlemiGeriAl [Undo operation]", OnAction:="İşlemiGeriAl"
.MenuItems.Add "Formül Sildirmemek [Delete the formula of order]", OnAction:="FormülSildirmemek"
.MenuItems.Add "Formül Sildirmek [Formula to Delete]", OnAction:="FormülSildirmek"
.MenuItems.Add "Formül Kopyala [Copy Formula]", OnAction:="FormülKopyala"
End With
.MenuItems.AddMenu "Diğer Özel Komutlar [Other Special Commands]", 2
With .MenuItems("Diğer Özel Komutlar [Other Special Commands]")
.MenuItems.Add "Fare Gizle [Mouse Hide]", OnAction:="FareGizle"
.MenuItems.Add "Fare Göster [Mouse UnHide]", OnAction:="FareGöster"
.MenuItems.Add "Klavye Ve Fareyi Şarta Bağlı Olarak Kilitle [BlockInput KeeyBoard and Mouse]", OnAction:="KlavyeVeFareyiŞartaBağlıOlarakKilitle"
.MenuItems.Add "Windows Gezginini Çağır [Call Explorer]", OnAction:="WindowsGezgininiÇağır"
.MenuItems.Add "Tüm CBB Düğmelerinin Resimleri [ListAllFaces]", OnAction:="TümCBBDüğmelerininResimleri"
.MenuItems.Add "Desktop Kısa Yol [DeskTop ShortCut]", OnAction:="DesktopKısaYol"
.MenuItems.Add "Ekran Görüntü Yoğunluğu [Screen Device Pixels]", OnAction:="EkranGörüntüYoğunluğu"
.MenuItems.Add "Başlat Bar Gizlensin [Start Bar Hidden]", OnAction:="BaşlatBarGizlensin"
.MenuItems.Add "Başlat Bar Görünsün [Start Bar UnHidden]", OnAction:="BaşlatBarGörünsün"
.MenuItems.Add "BaşlatAç [Open Start Bar]", OnAction:="BaşlatAç"
End With
End With
End Sub
Sub Auto_Close()

On Error Resume Next
Application.CommandBars("Cell").Reset
End Sub
Sub FormAç()

On Error Resume Next
Load UserForm1
End Sub

'SAYFA ÖZEL MAKROLARI


Sub GeriAlmayaDuyarlıİşlem()
'Sensitive Transaction Rollback

On Error Resume Next
If VBA.TypeName(Application.Selection) = "Range" Then
Application.ScreenUpdating = False
ReDim Hücre(Application.Selection.Count)
Set WB = Application.ActiveWorkbook
Set WS = Application.ActiveSheet
i = 1
For Each Alan In Application.Selection 'işlemden önce hücre yapısı geri lama hafızasına kaydadilir
Hücre(i).HücreVerisi = Alan.Formula
Hücre(i).HücreAdresi = Alan.Address
i = i + 1
Next Alan
Application.Selection.Formula = "X"
Application.OnUndo "İşlemi Geri Almak", "İşlemiGeriAl"
Else
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
Sub İşlemiGeriAl()
'Undo operation

Application.ScreenUpdating = False
On Error GoTo Hata
WB.Activate
WS.Activate
On Error GoTo 0
For i = 1 To UBound(Hücre)
Range(Hücre(i).HücreAdresi).Formula = Hücre(i).HücreVerisi
Next i
Set WB = Nothing
Set WS = Nothing
Erase Hücre
Application.ScreenUpdating = True
Hata:
End Sub
Sub FormülSildirmemek() 'Delete the formula of order
On Error Resume Next
Durum = True
Call FormülSilmeKontrolü
End Sub
Sub FormülSildirmek()
'Formula to Delete

On Error Resume Next
Durum = False
Call FormülSilmeKontrolü
End Sub
Sub FormülSilmeKontrolü
()
On Error Resume Next
If Durum = False Then Application.OnKey "{Del}": End
If Application.ActiveCell.HasFormula Then
Application.OnKey "{Del}", "FormülSildirmemeMesajı"
Else
Application.OnKey "{Del}"
End If
Application.OnTime VBA.Now + VBA.TimeValue("00:00:1"), "FormülSilmeKontrolü"
End Sub
Sub FormülSildirmemeMesajı()

On Error Resume Next
MsgBox " Formül silememe makrosu aktif durumdadır!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Formül Silme İşlemi İptali..."
End Sub
Sub FormülKopyala()
'Copy Formula

On Error Resume Next
Dim Formül(100)
HedefSatır As Double
Formül(1) = "=VLOOKUP(R[-1]C[-2],R1C3:R9C3,1,FALSE)"
Application.ActiveCell.Formula = Formül(1)
HedefSatır = Cells(65536, 3).End(xlUp).Row
Application.ActiveCell.AutoFill Destination:=Range("E2:E" & HedefSatır)
Application.Calculate
End Sub

'DİĞER ÖZEL MAKROLAR


Sub FareGizle()
'Mouse Hide


On Error Resume Next
Application.OnTime Now + TimeValue("00:00:05"), "FareGöster"
ShowCursor False
End Sub
Sub FareGöster()
'Mouse UnHide

On Error Resume Next
ShowCursor True
End Sub
Sub KlavyeVeFareyiŞartaBağlıOlarakKilitle()
'BlockInput KeeyBoard and Mouse

On Error Resume Next
DoEvents
BlockInput True
Call KilitŞartıİşlem
BlockInput False
End Sub
Sub KilitŞartıİşlem()

On Error Resume Next
Sleep 5000 '(5 saniye)
End Sub
Sub WindowsGezgininiÇağır()
'Call Explorer

On Error Resume Next
Shell "C:\WINDOWS\EXPLORER.EXE /n,/e,c:\", vbMaximizedFocus
'Shell (VBA.Environ("SystemRoot") & "\Explorer.exe"), 1
End Sub
Sub TümCBBDüğmelerininResimleri()
'ListAllFaces

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim cbCtl As CommandBarControl
Dim cbBar As CommandBar
On Error Resume Next
Application.Worksheets.Add
Set cbBar = CommandBars.Add(Position:=msoBarFloating, MenuBar:=False, temporary:=True)
Set cbCtl = cbBar.Controls.Add(Type:=msoControlButton, temporary:=True)
k = 1
Do While Err.Number = 0
For j = 1 To 10
i = i + 1
Application.StatusBar = "Face ID = " & i
cbCtl.FaceId = i
cbCtl.CopyFace
If Err.Number <> 0 Then Exit For
ActiveSheet.Paste Cells(k, j + 1)
Cells(k, j).Value = i
Next
k = k + 1
Loop
Application.StatusBar = False
cbBar.Delete
End Sub
Sub DesktopKısaYol()
'DeskTop ShortCut

On Error Resume Next
Dim KısaYol, Yol, Bağlantı
Set KısaYol = VBA.CreateObject("WScript.Shell")
Yol = KısaYol.SpecialFolders("Desktop")
Set Bağlantı = KısaYol.CreateShortcut(Yol & "\" & ActiveWorkbook.Name & ".lnk")
With Bağlantı
.TargetPath = ActiveWorkbook.FullName
.Save
End With
Set KısaYol = Nothing
End Sub
Sub EkranGörüntüYoğunluğu()
'Screen Pixels

On Error Resume Next
Dim Pix As Long
Pix = GetDC(0)
MsgBox "Görüntü Yoğunluğu : " & GetDeviceCaps(Pix, 8) & " * " & GetDeviceCaps(Pix, 10) & " pixels" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Ekran Görüntü Yoğunluğu..."
ReleaseDC 0, Pix
End Sub
Sub BaşlatBarGizlensin()
'Start Bar Hidden

On Error Resume Next
Dim hWnd1 As Long
hWnd1 = FindWindow("Shell_traywnd", "")
Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, Gizle)
End Sub
Sub BaşlatBarGörünsün()
'Start Bar UnHidden

On Error Resume Next
Dim hWnd1 As Long
hWnd1 = FindWindow("Shell_traywnd", "")
Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, Goster)
End Sub
Sub BaşlatAç()
'Open Start Bar

On Error Resume Next
Call keybd_event(VK_CONTROL, 0, 0, 0)
Call keybd_event(VK_ESCAPE, 0, 0, 0)
Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0)
Call keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0)
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