Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Eylül 2003 Pazartesi

Private PopUp Menus On The Page 03





'Module1

Option Explicit
Dim i As Single, ii As Single, No As Single, Adet As Double
Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Const Marka As String = "[PBİD]Program Bütçeleme ve İzleme Değerlendirme®"
Const MarkaSahibi As String = " 01ulusarac@superonline.com, 2004"
Dim Penecere As Long, Kontrol As Long
Dim CB As CommandBar, C As CommandBarControl, Yetkili As String, Hata
Public Type BROWSEINFO

hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Dim Başlama, FS, f, FC, F1, Bitiş, KlasörYolu, KlasörAdı, x, X0, X1, X2, Bulunan, Sonuncu, Büyüklük, TB1, TB2 As Worksheet, Mesaj As String
Dim Bilgi As BROWSEINFO, AramaYolu As String, r As Long, Bulgu As Integer
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function IsNetworkAlive Lib "SENSAPI.DLL" (ByRef lpdwFlags As Long) As Long
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Boolean
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Boolean
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Dim BağDeğer As Long
Sub Auto_Open()

On Error Resume Next
Application.DisplayAlerts = False
Application.EnableCancelKey = xlDisabled
With ShortcutMenus(xlWorksheetCell)
.MenuItems.AddMenu "Sayfa Özel Komutları [Page Special Commands]", 1
With .MenuItems("Sayfa Özel Komutları [Page Special Commands]")
.MenuItems.Add "İki Sayfanın Verilerini Karşılaştır [Two Page Data Compare]", OnAction:="İkiSayfanınVerileriniKarşılaştır"
.MenuItems.Add "Sorgulamalı NetWork Bağlantısı [Must question the Network Connection]", OnAction:="SorgulamalıNetWorkBağlantısı"
.MenuItems.Add "NetWork Bağlantısını Kes [Disconnect Network Connections]", OnAction:="NetWorkBağlantısınıKes"
.MenuItems.Add "Otomatik NetWork Bağlantısı [Automatic Network Connection]", OnAction:="OtomatikNetWorkBağlantısı"
.MenuItems.Add "Sorgulamalı Veri Bulma [Find Exact Match]", OnAction:="SorgulamalıVeriBulma"
.MenuItems.Add "Kaynağa Göre Son Satıra Kopyala [Copy to Last row Like Sorce Data]", OnAction:="KaynağaGöreSonSatıraKopyala"
.MenuItems.Add "Hedefe Göre Son Satıra Kopyala [Copy to Last row Like Target Data]", OnAction:="HedefeGöreSonSatıraKopyala"
End With
.MenuItems.AddMenu "Diğer Özel Komutlar [Other Special Commands]", 2
With .MenuItems("Diğer Özel Komutlar [Other Special Commands]")
.MenuItems.Add "Excel Kullanıcı Kimliği [Excel User ID]", OnAction:="ExcelKullanıcıKimliği"
.MenuItems.Add "Dosya Dizin Listesi Hazırlama [File Directory List Preparation]", OnAction:="DosyaDizinListesiHazırlama"
.MenuItems.Add "Çalışma Kitabı Klasöründeki Tüm Dosyalara Bağ Kurma [Workbook Links to All Files in Folder Set Up]", OnAction:="ÇalışmaKitabıKlasöründekiTümDosyalaraBağKurma"
.MenuItems.Add "Çalışılan Dosyayı Yedekleme [Save Workbook Backup]", OnAction:="ÇalışılanDosyayıYedekleme"
.MenuItems.Add "Saklamadan Çık [Exit without save]", OnAction:="SaklamadanÇık"
.MenuItems.Add "Temp Klasöründeki Dosyaları Tanıt [Identify the files from Temp Folder]", OnAction:="TempKlasöründekiDosyalarıTanıt"
.MenuItems.Add "İşlemci Hızı [Processor Speed]", OnAction:="İşlemciHızı"
.MenuItems.Add "HücreSeçmeÖrnekleri [Range select example]", OnAction:="HücreSeçmeÖrnekleri"
End With
End With
Yetkili = VBA.InputBox("Program kullanıcı adınızı yazınız..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", "[PBİD®] PopUp Komutları Yetkilendirme", "")
If Yetkili = "ULUSARAÇ" Then
Call YetkiAç
Else
Call YetkiKapat
End If
End Sub
Sub Auto_Close()

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

On Error Resume Next
Load UserForm1
End Sub

'SAYFA ÖZEL MAKROLARI


Sub İkiSayfanınVerileriniKarşılaştır()
'Two Page Data Compare

On Error Resume Next
Dim Sayfa1 As Worksheet, Sayfa2 As Worksheet, Bul As Range, Soyad, Adres
Set Sayfa1 = Worksheets("Sayfa1")
Set Sayfa2 = Worksheets("Sayfa2")
For i = 2 To Sayfa2.Cells(65536, "A").End(xlUp).row
Soyad = Sayfa2.Cells(i, 1)
Set Bul = Sayfa1.Range("A:A").Find(Soyad, Lookat:=xlWhole)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
If Sayfa2.Cells(i, 1) = Bul.Offset(0, 0) Then
Bul.Offset(0, 1) = "Bulundu"
End If
Set Bul = Sayfa1.Range("A:A").FindNext(Bul)
Loop Until Adres = Bul.Address
End If
Next i
End Sub
Sub SorgulamalıNetWorkBağlantısı()
'Must question the Network Connection

On Error Resume Next
If IsNetworkAlive(BağDeğer) = 0 Then
InternetAutodial 1, 0
End If
End Sub
Sub NetWorkBağlantısınıKes()
'Disconnect Network Connections

On Error Resume Next
If (IsNetworkAlive(BağDeğer) <> 0) Then
InternetAutodialHangup 0
End If
End Sub
Sub OtomatikNetWorkBağlantısı()
'Automatic Network Connection

On Error Resume Next
Call Shell("c:\windows\system32\rasdial.exe " & Chr$(34) & "ttnet" & Chr$(34) & " " & "sirenko" & " " & "sifre") 'Şifre Tanıtımı
If IsNetworkAlive(BağDeğer) = 0 Then
InternetAutodial 2, 0
End If
End Sub
Sub SorgulamalıVeriBulma()
'Find Exact Match

Dim MyStr As String, InfoMsg As String, myData
Dim Rng1 As String, LookupValue As String
Dim MyQ As VbMsgBoxResult
Dim FoundRng As Variant
MyStr = Trim(Application.InputBox("Aranacak metni girin !", "[PBİD®] Sorgulamalı Veri Bulmak..."))
If Not MyStr = "False" Then
Set FoundRng = Cells.Find(MyStr, LookIn:=xlValues, Lookat:=xlPart)
If Not FoundRng Is Nothing Then Rng1 = FoundRng.Address: FoundRng.Activate
Hata2:
If Right(FoundRng.Value, 1) <> " " Then LookupValue = FoundRng.Value & " ": myData = Split(LookupValue, " ", , vbTextCompare)
For i = LBound(myData) To UBound(myData)
If myData(i) = MyStr Then
InfoMsg = "Aranan metin " & FoundRng.Address(False, False) & " hücresinde bulundu." & vbCrLf & vbCrLf & "Bulunan hücrenin içeriği :" & vbCrLf & vbCrLf & FoundRng.Value & vbCrLf & vbCrLf & "[PBİD®] Aramaya devam etmek istiyormusunuz ?"
MyQ = MsgBox(InfoMsg, vbInformation + vbYesNo, "[PBİD®] Arama sonucu...")
If MyQ = vbYes Then GoTo Hata1:
Exit Sub
End If
Next
Else
MsgBox "Aranan değer bulunamadı !", vbInformation, "[PBİD®] Arama sonucu..."
Exit Sub
End If
Hata1:
Set FoundRng = Cells.FindNext(FoundRng)
If Rng1 = FoundRng.Address Then
MsgBox "Aranan değerden başka bulunamadı !", vbInformation, "[PBİD®] Arama sonucu..."
Exit Sub
End If
FoundRng.Activate
GoTo Hata2:
End If
Set FoundRng = Nothing
End Sub
Sub KaynağaGöreSonSatıraKopyala()
'Copy to Last row Like Sorce Data

On Error Resume Next
Dim KaynakAlan As Range
Dim HedefAlan As Range
Dim Durum As Long
Durum = SonSatır(Sheets("Sayfa1")) + 1
Set KaynakAlan = Sheets("Sayfa1").Range("A1:c10")
Set HedefAlan = Sheets("Sayfa2").Range("A" & Durum)
KaynakAlan.Copy HedefAlan
End Sub
Sub HedefeGöreSonSatıraKopyala()
'Copy to Last row Like Target Data

On Error Resume Next
Dim KaynakAlan As Range
Dim HedefAlan As Range
Dim Durum As Long
Durum = SonSatır(Sheets("Sayfa2")) + 1
Set KaynakAlan = Sheets("Sayfa1").Range("A1:c10")
With KaynakAlan
Set HedefAlan = Sheets("Sayfa2").Range("A" & Durum).Resize(.Rows.count, .Columns.count)
End With
HedefAlan.Value = KaynakAlan.Value
End Sub
Function SonSatır(sh As Worksheet)

On Error Resume Next
SonSatır = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).row
On Error GoTo 0
End Function
Function SonKolon(sh As Worksheet)

On Error Resume Next
SonKolon = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function

'DİĞER ÖZEL MAKROLAR

Sub ExcelKullanıcıKimliği()
'Excel User ID

On Error Resume Next
Penecere = GetActiveWindow()
Kontrol = ShellAbout(Penecere, Marka, Chr(13) & Chr(169) & MarkaSahibi & Chr(13), 0)
End Sub
Sub YetkiAç()

On Error Resume Next
Yetkilendirme 21, True 'Kes
Yetkilendirme 19, True ' Kopyala
Yetkilendirme 22, True ' Yapıştır
Yetkilendirme 755, True ' özelyapıştır
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "+{DEL}", ""
Application.OnKey "+{INSERT}", ""
Application.CellDragAndDrop = True
CommandBars("ToolBar List").Enabled = True
End Sub
Sub YetkiKapat()

On Error Resume Next
Yetkilendirme 21, False 'Kes
Yetkilendirme 19, False ' Kopyala
Yetkilendirme 22, False ' Yapıştır
Yetkilendirme 755, False ' özelyapıştır
Application.OnKey "^c", "Yasaklıİşlemler"
Application.OnKey "^v", "Yasaklıİşlemler"
Application.OnKey "+{DEL}", "Yasaklıİşlemler"
Application.OnKey "+{INSERT}", "Yasaklıİşlemler"
Application.CellDragAndDrop = False 'hücreyi çoğaltma ve taşıma
CommandBars("ToolBar List").Enabled = False 'düzen menüsündeki ilgili menüleri gizle
End Sub
Sub Yetkilendirme(KomutNo As Integer, Enabled As Boolean)

On Error Resume Next
For Each CB In Application.CommandBars
Set C = CB.FindControl(Id:=KomutNo, Recursive:=True)
If Not C Is Nothing Then C.Enabled = Enabled
Next
End Sub
Sub Yasaklıİşlemler()

On Error Resume Next
MsgBox "Üzgünüm yapmak istediğiniz işlem yasaklanmıştır.!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] PopUp Komutları Yetkilendirme"
End Sub
Sub DosyaDizinListesiHazırlama()
'File Directory List Preparation

On Error Resume Next
Application.DisplayAlerts = False
Set TB1 = ThisWorkbook.Worksheets(1)
Set TB2 = ThisWorkbook.Worksheets(2)
Başlama = Now
TB1.[A:D] = ""
TB2.[A:D] = ""
Mesaj = "Lütfen bir klasör seçin:"
KlasörYolu = KlasörBulucu(Mesaj)
If KlasörYolu = "" Then Exit Sub
KlasörAdı = VBA.Dir(KlasörYolu, VBA.vbDirectory)
TB1.[A2] = KlasörYolu
No = 2
TB1.[A1] = "Dosya Yolu"
TB1.[B1] = "Bölge"
TB1.[C1] = "Dosya Sayısı"
TB1.[D1] = "Arama Süresi"
X0 = 2
X1 = 2
Do While (TB1.Cells(Rows.count, 1).End(xlUp).row <> TB1.Cells(Rows.count, 2).End(xlUp).row)
For X2 = X0 To X1
KlasörYolu = TB1.Cells(X2, 1)
If Right(KlasörYolu, 1) <> "\" Then KlasörYolu = KlasörYolu & "\"
KlasörAdı = Dir(KlasörYolu, vbDirectory)
Bulunan = 0
Do While (KlasörAdı <> "")
If (KlasörAdı <> ".") And (KlasörAdı <> "..") Then
If (VBA.GetAttr(KlasörYolu & KlasörAdı) And VBA.vbDirectory) = VBA.vbDirectory Then
No = No + 1
TB1.Cells(No, 1) = KlasörYolu & KlasörAdı & "\"
Bulunan = Bulunan + 1
End If
End If
KlasörAdı = VBA.Dir
Loop
TB1.Cells(X2, 2) = Bulunan
Next X2
X0 = X1 + 1
X1 = X2
Loop
Sonuncu = TB1.Cells(Rows.count, 1).End(xlUp).row
i = 1
ii = 0
For Bulunan = 2 To Sonuncu
No = 0
Büyüklük = 0
Set FS = CreateObject("Scripting.FileSystemObject")
Set f = FS.GetFolder(TB1.Cells(Bulunan, 1))
Set FC = f.Files
For Each F1 In FC
If i = 65536 Then
ii = ii + 1
ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.count)
ThisWorkbook.Worksheets(ii + 2).Name = "Dosyalar " & ii + 1
Set TB2 = ThisWorkbook.Worksheets(ii + 2)
i = 1
End If
i = i + 1
No = No + 1
TB2.Cells(i, 1) = F1.Name
TB2.Cells(i, 2) = f & "\" & F1.Name
TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:=f & "\" & F1.Name
TB2.Cells(i, 3) = FileLen(F1)
TB2.Cells(i, 4) = FileDateTime(F1)
Büyüklük = Büyüklük + FileLen(F1)
Next F1
TB1.Cells(Bulunan, 3) = No
TB1.Cells(Bulunan, 4) = Büyüklük / 1024 / 1024
Next Bulunan
Bitiş = Now
End Sub
Function KlasörBulucu(Optional Mesaj) As String

Bilgi.pidlRoot = 0&
If VBA.IsMissing(Mesaj) Then
Bilgi.lpszTitle = "Lütfen bir klasör seçin."
Else
Bilgi.lpszTitle = Mesaj
End If
Bilgi.ulFlags = &H1
x = SHBrowseForFolder(Bilgi)
AramaYolu = VBA.Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal AramaYolu)
If r Then
Bulgu = VBA.InStr(AramaYolu, Chr$(0))
KlasörBulucu = VBA.Left(AramaYolu, Bulgu - 1)
Else
KlasörBulucu = ""
End If
End Function
Sub ÇalışmaKitabıKlasöründekiTümDosyalaraBağKurma()
'Workbook Links to All Files in Folder Set Up

On Error Resume Next
Set FS = VBA.CreateObject("Scripting.FileSystemObject")
Set f = FS.GetFolder(ActiveWorkbook.path)
Set FC = f.Files
i = 1
For Each F1 In FC
If (F1.Name <> "Veri999.xls") Then
Sheets("Sayfa1").Range("a" & i).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=F1.Name, TextToDisplay:=Mid(F1.Name, 1, Len(F1.Name) - 4)
ActiveCell.Offset(0, 1) = F1.Size
ActiveCell.Offset(0, 2) = f & "\" & F1.Name
ActiveCell.Offset(0, 3) = F1.Type
ActiveCell.Offset(0, 4) = F1.DateLastModified
ActiveCell.Offset(0, 5) = F1.DateLastAccessed
ActiveCell.Offset(0, 6) = F1.DateCreated
i = i + 1
End If
Next
End Sub
Sub ÇalışılanDosyayıYedekleme()
'Save Workbook Backup

Dim AWB As Workbook, YedeklemeAdı As String, OK As Boolean
If VBA.TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
Set AWB = Application.ActiveWorkbook
If AWB.path = "" Then
Application.Dialogs(xlDialogSaveAs).Show
Else
YedeklemeAdı = AWB.FullName i = 0
While (InStr(i + 1, YedeklemeAdı, ".") > 0)
i = InStr(i + 1, YedeklemeAdı, ".")
Wend
If (i > 0) Then YedeklemeAdı = VBA.Left(YedeklemeAdı, i - 1)
YedeklemeAdı = YedeklemeAdı & ".bak"
OK = False
On Error GoTo Hata
With AWB
Application.StatusBar = ThisWorkbook.Name & ".xls olarak saklandı..."
.Save
Application.StatusBar = ThisWorkbook.Name & ".bak olarak saklandı..."
.SaveCopyAs YedeklemeAdı
OK = True
End With
End If
Hata:
Set AWB = Nothing
Application.StatusBar = False
If Not OK Then
MsgBox ThisWorkbook.Name & ".bak olarak saklanamdı", vbExclamation, "[PBİD®] " & ThisWorkbook.Name
End If
End Sub
Sub SaklamadanÇık()
'Exit without save

On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Close True
End Sub
Sub TempKlasöründekiDosyalarıTanıt()
'Identify the files from Temp Folder

Const SabitKlasör As String = "C:\Temp\"
Const RaporSayfası As String = "Sayfa1"
Dim ArananDosya As String, Dosya As String, i As Long, j As Integer
Range("A1:E100").ClearContents
Dosya = VBA.Dir(SabitKlasör & Application.PathSeparator & "*.xls", VBA.vbDirectory)
Do While (Dosya <> "")
If Dosya = ThisWorkbook.Name Then GoTo Hata:
ArananDosya = "'" & SabitKlasör & "[" & Dosya & "]" & RaporSayfası & "'!R"
For j = 1 To 5
For i = 1 To 10
Cells(i, j) = Cells(i, j) + Application.ExecuteExcel4Macro(ArananDosya & i & "C" & j)
Next
Next
Hata:
Dosya = VBA.Dir
Loop
End Sub
Sub İşlemciHızı()
'Processor Speed

On Error Resume Next
Dim objWMI As Object, Cpu As Object
Set objWMI = VBA.GetObject("WinMgmts:").InstancesOf("Win32_Processor")
For Each Cpu In objWMI
MsgBox Cpu.Name & " " & Cpu.CurrentClockSpeed & " Mhz", vbInformation
Next
Set objWMI = Nothing
End Sub
Sub HücreSeçmeÖrnekleri()
'Range select example

On Error Resume Next
Dim r1 As Range, r2 As Range, rAll As Range
Set r1 = Range("A1", "A3")
Set r2 = Range("C3", "C8")
Set rAll = Union(r1, r2)
rAll.Select
'A1:A3 VE C3:C8 HÜCRE ARALIĞINI SEÇER
ActiveCell.Offset(3, 2).Select
'Aktif hücrenin 3 satır altındaki, iki sütun önündeki hücreyi seçer
Selection.EntireColumn.Select
'AKTİF SÜTUNU SEÇSelection.EntireRow.Select 'AKTİF SATIRI SEÇ
Cells.Select
'TÜM HÜCRELERİ SEÇ
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select 'DOLU HÜCRELERİN ALTINDAKİ BOŞ HÜCREYİ SEÇER
Loop
ActiveCell.Offset(0, 1).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select 'AKTİF HÜCRELERİN SAĞ TARAFINDAKİ BOŞ HÜCREYİ SEÇER
Loop
Set LeftCell = Cells(ActiveCell.row, 1)
Set RightCell = Cells(ActiveCell.row, 256)
If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
'AKTİF HÜCRENİN SAĞINDAKİ VE SOLUNDAKİ DOLU HÜCRELERİ SEÇERIf IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft) 'AKTİF HÜCRENİN SAĞINDAKİ VE SOLUNDAKİ DOLU HÜCRELERİ SEÇERIf LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select 'AKTİF HÜCRENİN SAĞINDAKİ VE SOLUNDAKİ DOLU HÜCRELERİ SEÇER
Range(ActiveCell, ActiveCell.End(xlDown)).Select
'AKTİF HÜCRENİN ALTINDAN BAŞLAYARAK EN SON HÜCREYE KADAR SEÇERApplication.ScreenUpdating = False
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