Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Ağustos 2003 Cuma

Private PopUp Menus On The Page 01





'Module1

Option Explicit
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Dim i As Single, ii As Single, No As Single
Dim Adet As Double
Dim AlanAd As Name
Dim AraYüzSayfası As DialogSheet
Dim WS As Worksheet, Hücre As Range
Dim BulguListesi As New Collection
Dim Veri As Variant
Dim PDFOkumaMetni As String, PDFBağlantı, PDFYazıcı As String, PDFSürücü As String, PDFBağlantıYeri As String, PDFKopya As Double, PDFKopyalama As Long
Sub Auto_Open()

On Error Resume Next
With ShortcutMenus(xlWorksheetCell)
.MenuItems.AddMenu "Sayfa Özel Komutları [Page Special Commands]", 1
With .MenuItems("Sayfa Özel Komutları [Page Special Commands]")
.MenuItems.Add "Sayfa Listesi Ara Yüzü [Page List Interface]", OnAction:="SayfaListesiAraYüzü"
.MenuItems.Add "Alan Adlarını Sil [Deleted Range Names]", OnAction:="AlanAdlarınıSil"
.MenuItems.Add "Kullanılan Alan İçinde Kal [Stay Within The Region Used]", OnAction:="KullanılanAlanİçindeKal"
.MenuItems.Add "Tüm Alanları Kullan [Using All Fields]", OnAction:="TümAlanlarıKullan"
.MenuItems.Add "Sayfadaki Tüm Resimleri Sil [Delete All Images On The Page]", OnAction:="SayfadakiTümResimleriSil"
.MenuItems.Add "KüçükHarf Yazdırmama Koşulunu Kaldır [Remove LOWER Writing Requirements]", OnAction:="KüçükHarfYazdırmamaKoşulunuKaldır"
.MenuItems.Add "Küçük Harf Yazdırmama Koşulunu Getir [Bring Case LOWER Writing Requirements]", OnAction:="KüçükHarfYazdırmamaKoşulunuGetir"
.MenuItems.Add "Ara Bul Listele [Call, Search And Listings]", OnAction:="AraBulListele"
End With
.MenuItems.AddMenu "Diğer Özel Komutlar [Other Special Commands]", 2
With .MenuItems("Diğer Özel Komutlar [Other Special Commands]")
.MenuItems.Add "Saat Tarih Ayarlama Seti [Set Time, Date]", OnAction:="SaatTarihAyarlamaSeti"
.MenuItems.Add "Yazıcı Listesi [Printer List]", OnAction:="YazıcıListesi"
.MenuItems.Add "İşletim Sistemi Bilgileri [Operating System Information]", OnAction:="İşletimSistemiBilgileri"
.MenuItems.Add "Sayfadaki Koruma Şifresini Çöz [Solving the Password Protection On Page]", OnAction:="SayfadakiKorumaŞifresiniÇöz"
.MenuItems.Add "Tüm Sayfalardaki Korumayı Kaldır [Remove the Protection of All Pages]", OnAction:="TümSayfalardakiKorumayıKaldır"
.MenuItems.Add "Tüm Sayfalarda Şifresiz Koruma Yap [All Pages without password protection]", OnAction:="TümSayfalardaŞifresizKorumaYap"
.MenuItems.Add "Sayfaları İsme Göre Sırala [Pages Sort By Name]", OnAction:="SayfalarıİsmeGöreSırala"
.MenuItems.Add "Sayfaları Indexe Göre Sırala [Pages Sort By Index]", OnAction:="SayfalarıIndexeGöreSırala"
.MenuItems.Add "Sayfaya Windows Gezgininden Resim Ekle [Page from Windows Explorer, Insert Picture]", OnAction:="SayfayaWindowsGezginindenResimEkle"
.MenuItems.Add "AltPrtScn Tarzında Resim Çek Ve Sayfaya Ekle [And by taking a picture Add a Page Style AltPrtScn]", OnAction:="AltPrtScnTarzındaResimÇekVeSayfayaEkle"
.MenuItems.Add "Pdf Dosya Okuma [Pdf File Reading]", OnAction:="PdfDosyaOkuma"
.MenuItems.Add "Pdf Dosya Yazdırma [Pdf File Printing]", OnAction:="PdfDosyaYazdırma"
End With
End With
End Sub
Sub Auto_Close()

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

'SAYFA ÖZEL MAKROLARI

Sub SayfaListesiAraYüzü()

On Error Resume Next
No = 0
ReDim Hafıza(0 To No, 0 To 1)
For Each WS In ActiveWorkbook.Worksheets
If WS.Visible Then Hafıza(No, 1) = WS.Name: No = No + 1
Next WS
Call AraYüzOluştur(Hafıza)
Erase Hafıza
End Sub
Private Function AraYüzOluştur(ByVal AraYüzBilgisi)
On Error Resume Next
Application.ScreenUpdating = False
Set AraYüzSayfası = ActiveWorkbook.DialogSheets.Add
With AraYüzSayfası
With .DialogFrame
.Text = "[PBİD®] Sayfa Seçiciniz"
.Left = 0
.Top = 0
.Height = 145
.Width = 300
End With
With .ListBoxes.Add(6, 18, 230, 115)
.AddItem AraYüzBilgisi
.ListIndex = 0
.OnAction = "DisplaySheet"
End With
.Buttons(1).Left = 245
.Buttons(2).Left = 245
.Visible = False
End With
Application.ScreenUpdating = True: AraYüzSayfası.Show: Application.DisplayAlerts = False: AraYüzSayfası.Delete: Application.DisplayAlerts = True
Set WS = Nothing
Set AraYüzSayfası = Nothing
End Function
Private Sub DisplaySheet()

On Error Resume Next
Sheets(AraYüzSayfası.ListBoxes(1).List(AraYüzSayfası.ListBoxes(1).ListIndex)).Activate
End Sub
Sub AlanAdlarınıSil()

On Error Resume Next
For Each AlanAd In Names
ActiveWorkbook.Names(AlanAd.Name).Delete
Next AlanAd
End Sub
Sub SadeceFormüllerKorumalı()

On Error GoTo Hata
Application.ScreenUpdating = False
With ActiveSheet
.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
With .UsedRange
.Locked = False
.FormulaHidden = False
.Font.Color = vbBlue
With .SpecialCells(xlFormulas, 23)
.Locked = True
.FormulaHidden = False
.Font.Color = vbBlack
End With
End With
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Application.ScreenUpdating = True
Exit Sub
Hata:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
Application.ScreenUpdating = True
End Sub
Sub KullanılanAlanİçindeKal()

On Error Resume Next
With ActiveSheet
.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
.ScrollArea = .UsedRange.Address
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub
Sub TümAlanlarıKullan()

On Error Resume Next
With ActiveSheet
.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
.ScrollArea = ""
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub
Sub SayfadakiTümResimleriSil()

On Error Resume Next
With ActiveSheet
.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
.DrawingObjects.Delete
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
End Sub
Private Sub Workbook_Deactivate()

With Application.AutoCorrect
.DeleteReplacement What:="a"
End With
End Sub
Sub KüçükHarfYazdırmamaKoşulunuKaldır()

On Error Resume Next
For i = 1 To 255
With Application.AutoCorrect
.DeleteReplacement What:=VBA.LCase(VBA.Chr(i))
End With
Next i
End Sub
Sub KüçükHarfYazdırmamaKoşulunuGetir()

On Error Resume Next
For i = 1 To 255
With Application.AutoCorrect
.AddReplacement What:=VBA.LCase(VBA.Chr(i)), Replacement:=VBA.UCase(VBA.Chr(i))
End With
Next i
End Sub
Sub AraBulListele()

On Error Resume Next
Veri = VBA.InputBox("Aranan Veriyi Belirtiniz" & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", "[PBİD®] Veri Arama", "")
Veri = "*" & Veri & "*"
Set WS = ActiveSheet
No = 0
Adet = Application.WorksheetFunction.CountIf(WS.UsedRange, Veri)
ReDim Hafıza((Adet - 1), 0)
For Each Hücre In WS.UsedRange
If (Application.WorksheetFunction.CountIf(Hücre, Veri) > 0) Then
Hafıza(No, 0) = Hücre.Address & ": " & Hücre.Value
No = No + 1
End If
Next Hücre
Call AraYüzOluştur(Hafıza)
Erase Hafıza
End Sub

'DİĞER ÖZEL MAKROLAR

Private Sub SaatTarihAyarlamaSeti()

On Error Resume Next
VBA.Shell "Rundll32.exe Shell32.dll,Control_RunDLL TimeDate.cpl", vbNormalFocus
End Sub
Sub YazıcıListesi()

On Error Resume Next
VBA.Shell "Rundll32.exe Shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder"
End Sub
Sub İşletimSistemiBilgileri()

On Error Resume Next
Dim Tanım As String, İşletimSistemi As Object, Eleman As Object, Ayraç As String
Ayraç = Application.WorksheetFunction.Rept("=", 36)
Set İşletimSistemi = GetObject("Winmgmts:").InstancesOf("Win32_ComputerSystem")
For Each Eleman In İşletimSistemi
Tanım = "SİSTEM BİLGİLERİ" & vbCrLf
Tanım = Tanım & Ayraç & vbCrLf
Tanım = Tanım & "Sistem Adı" & VBA.Chr(9) & Eleman.Name & vbCrLf
Tanım = Tanım & "İşletim Durumu" & VBA.Chr(9) & Eleman.Status & vbCrLf
Tanım = Tanım & "İşletim Tipi" & VBA.Chr(9) & Eleman.SystemType & vbCrLf
Tanım = Tanım & "Üretici Firma" & VBA.Chr(9) & Eleman.Manufacturer & vbCrLf
Tanım = Tanım & "Üretim Modeli" & VBA.Chr(9) & Eleman.Model & vbCrLf
Tanım = Tanım & "Fiziksel Hafıza" & VBA.Chr(9) & Eleman.TotalPhysicalMemory / 1024000 & " MBayt" & vbCrLf
Tanım = Tanım & "Ağ İçi Alan" & VBA.Chr(9) & Eleman.Domain & vbCrLf
Tanım = Tanım & "Ağ İçi Konumu" & VBA.Chr(9) & RoleTanımlaması(Eleman.DomainRole) & vbCrLf
Tanım = Tanım & "Kullanıcı Adı" & VBA.Chr(9) & Eleman.UserName & vbCrLf
Tanım = Tanım & Ayraç & vbCrLf
MsgBox Tanım & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] İşletim Sistemi Tanımlaması"
Next
Set İşletimSistemi = Nothing
End Sub
Function RoleTanımlaması(ByVal roleID) As String

On Error Resume Next
Dim RetString As String
Select Case roleID
Case 0
RetString = "Standalone Workstation"
Case 1
RetString = "Member Workstation"
Case 2
RetString = "Standalone Server"
Case 3
RetString = "Member Server"
Case 4
RetString = "Backup Domain Controller"
Case 5
RetString = "Primary Domain Controller"
Case Else
RetString = "Unknown"
End Select
RoleTanımlaması = RetString
End Function
Sub SayfadakiKorumaŞifresiniÇöz()

On Error Resume Next
WS = Application.ActiveSheet
Call SayfadakiŞifreyiKırmak(WS)
End Sub
Private Function SayfadakiŞifreyiKırmak(WS)

On Error Resume Next
Dim Sorgu1 As Integer, Sorgu2 As Integer, Sorgu3 As Integer
Dim Sorgu4 As Integer, Sorgu5 As Integer, Sorgu6 As Integer
Dim Sorgu7 As Integer, Sorgu8 As Integer, Sorgu9 As Integer
Dim Sorgu10 As Integer, Sorgu11 As Integer, Sorgu12 As Integer
No = 0
For Sorgu1 = 65 To 66
For Sorgu2 = 65 To 66
For Sorgu3 = 65 To 66
For Sorgu4 = 65 To 66
For Sorgu5 = 65 To 66
For Sorgu6 = 65 To 66
For Sorgu7 = 65 To 66
For Sorgu8 = 65 To 66
For Sorgu9 = 65 To 66
For Sorgu10 = 65 To 66
For Sorgu11 = 65 To 66
For Sorgu12 = 32 To 126
No = No + 1
Application.StatusBar = WS.Name & "de denenen: " & Chr(Sorgu1) & Chr(Sorgu2) & Chr(Sorgu3) & Chr(Sorgu4) & Chr(Sorgu5) & Chr(Sorgu6) & Chr(Sorgu7) & Chr(Sorgu8) & Chr(Sorgu9) & Chr(Sorgu10) & Chr(Sorgu11) & Chr(Sorgu12)
ActiveSheet.Unprotect Chr(Sorgu1) & Chr(Sorgu2) & Chr(Sorgu3) & Chr(Sorgu4) & Chr(Sorgu5) & Chr(Sorgu6) & Chr(Sorgu7) & Chr(Sorgu8) & Chr(Sorgu9) & Chr(Sorgu10) & Chr(Sorgu11) & Chr(Sorgu12)
DoEvents
If ActiveSheet.ProtectContents = False Then
Application.StatusBar = ""
Exit Function
End If
Next Sorgu12
Next Sorgu11
Next Sorgu10
Next Sorgu9
Next Sorgu8
Next Sorgu7
Next Sorgu6
Next Sorgu5
Next Sorgu4
Next Sorgu3
Next Sorgu2
Next Sorgu1
End Function
Sub TümSayfalardakiKorumayıKaldır()

On Error Resume Next
For Each WS In ActiveWorkbook.Worksheets
Call SayfadakiŞifreyiKırmak(WS)
Next WS
End Sub
Sub TümSayfalardaŞifresizKorumaYap()
On Error Resume Next
For Each WS In ActiveWorkbook.Worksheets
WS.Protect ""
Next WS
End Sub
Sub SayfalarıİsmeGöreSırala()

On Error Resume Next
Dim j As Integer, Min As Integer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
With ActiveWorkbook.Worksheets
For i = 1 To .Count - 1
Min = i
For j = i + 1 To .Count
If ((.item(j).Name < .item(Min).Name)) Then Min = j
Next j
If (Min <> i) Then .item(Min).Move Before:=Worksheets(i)
Next i
End With
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub SayfalarıIndexeGöreSırala()

On Error Resume Next
Dim j As Integer, Min As Integer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
With ActiveWorkbook.Worksheets
For i = 1 To .Count - 1
Min = i
For j = i + 1 To .Count
If (.item(j) < .item(Min)) Then Min = j
Next j
If (Min <> i) Then .item(Min).Move Before:=Worksheets(i)
Next i
End With
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub SayfayaWindowsGezginindenResimEkle()

On Error Resume Next
Dim Yol
Dim Resim As Object
Yol = Application.GetOpenFilename("Resim dosyaları(*.gif;*.jpg;*.bmp),*.gif;*.jpg;*.bmp", , "[PBİD®] Sayfaya eklenecek resim seçimi...", , False)
If Yol = False Then Exit Sub
Set Resim = ActiveSheet.Pictures.Insert(Yol)
With Resim
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 36
.ShapeRange.Width = 36
.ShapeRange.Rotation = 0#
.ShapeRange.Name = ActiveCell.Offset(0, 1).Value
End With
End Sub
Sub AltPrtScnTarzındaResimÇekVeSayfayaEkle()

On Error Resume Next
Call keybd_event(vbKeySnapshot, 0, 0, 0)
DoEvents
ActiveSheet.Paste
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 6#
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineThickBetweenThin
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 283.5
Selection.ShapeRange.Width = 504#
Selection.ShapeRange.Rotation = 0#
Selection.Locked = False
End Sub
Sub PdfDosyaOkuma()

On Error Resume Next
PDFOkumaMetni = Application.GetOpenFilename("PDF Files,*.pdf,All Files,*.*", 1, "Open File", , False)
Set PDFBağlantı = CreateObject("WScript.Shell")
PDFBağlantı.Run "AcroRd32.exe" & " " & PDFOkumaMetni, vbMaximizedFocus
End Sub
Sub PdfDosyaYazdırma()

On Error Resume Next
PDFOkumaMetni = Application.GetOpenFilename("PDF Files,*.pdf,All Files,*.*", 1, "Open File", , False)
PDFYazıcı = """Microsoft Office Document Image Writer"""
PDFSürücü = """Microsoft Office Document Image Writer"""
PDFBağlantıYeri = """Microsoft Office Document Image Writer port:"""
PDFKopya = 1
Set PDFBağlantı = CreateObject("WScript.Shell")
For PDFKopyalama = 1 To PDFKopya
PDFBağlantı.Run ("AcroRd32.exe /t " & PDFOkumaMetni & " " & PDFYazıcı & " " & PDFSürücü & " " & PDFBağlantıYeri)
Next
MsgBox "Veri gönderildi. " & vbLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Pdf dosya okuma ve yazdırma..."
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