Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ağustos 2003 Çarşamba

WorkSheets Sort


'Module1

Sub Auto_Open()
Dim i As Integer
Dim j As Integer
If Worksheets.Count = 1 Then Exit Sub
For i = 1 To Worksheets.Count - 1
For j = i + 1 To Worksheets.Count
If Worksheets(j).Name <> ""
Worksheets(j).Move before:=Worksheets(i)
End If
Next j
Next i
End Sub

10 Ağustos 2003 Pazar

Private PopUp Menus On The Page 02




'Module1

Option Explicit
Dim i As Single, ii As Single, No As Single
Dim Adet As Double
Dim SubTotalAlanı As Range, AltToplam As Double, HesTipNo As Double 'Process No
Dim PCPrinteri As String, AğPrinteri As String, PCPrinterAdı As String, GörevliPrinterAdı As String, AğPrinterAdı As String, Yoklama As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private mp3Çalar As Boolean, mp3Dosya As String
Dim CB As CommandBar, ÖzelCB As CommandBar, ÖzelAltMenü As CommandBarPopup, ÖzelMenüDüğmesi As CommandBarButton
Dim Program As Outlook.Application, Mesaj As Outlook.MailItem, MesajTarihi As Date
Dim Hücre As Range, Formül As String, FormülVerisi As String
Dim KısaYol As Object, İkon As Object, MasaÜstüYolu As String, DosyaAdı As String, Yol As String
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 "Koşullu Alt Toplam [SubTotal]", OnAction:="KoşulluAltToplam"
.MenuItems.Add "Tekrarlanan Verileri Boyama [Dublicate Data Painting]", OnAction:="TekrarlananVerileriBoyama"
.MenuItems.Add "Tekrarlanan Veriyi Satır Olarak Silme [Remove Duplicates]", OnAction:="TekrarlananVeriyiSatırOlarakSilme"
.MenuItems.Add "Hücreye Formül Eklemek [Add Formula to Cell]", OnAction:="HücreyeFormülEklemek"
.MenuItems.Add "İkiTarihArasındaGeçenGünSayısı [Day diffarence of two dates]", OnAction:="İkiTarihArasındaGeçenGünSayısı"
.MenuItems.Add "TamSayıEldeEtmek [Torn to integer number]", OnAction:="TamSayıEldeEtmek"
End With
.MenuItems.AddMenu "Diğer Özel Komutlar [Other Special Commands]", 2
With .MenuItems("Diğer Özel Komutlar [Other Special Commands]")
.MenuItems.Add "Ağ Printerde Yazdırma [PrintToNetworkPrinterExample]", OnAction:="AğPrinterdeYazdırma"
.MenuItems.Add "mp3 Başlat [mp3 Play]", OnAction:="mp3Başlat"
.MenuItems.Add "mp3 Durudur [mp3 Stop]", OnAction:="mp3Durudur"
.MenuItems.Add "Çalışma Kitabına Özel MenüKur [Make Special CB Menu]", OnAction:="ÇalışmaKitabınaÖzelMenüKur"
.MenuItems.Add "Çalışma Kitabındaki Özel Menüyü Sil [Delete Special CB Menu]", OnAction:="ÇalışmaKitabındakiÖzelMenüyüSil"
.MenuItems.Add "Takvim Mesajı [Calendar Message]", OnAction:="TakvimMesajı"
.MenuItems.Add "Çoklu Mesaj Göndermek [Multi Email]", OnAction:="ÇokluMesajGöndermek"
.MenuItems.Add "Masa Üstüne Dosya Kısa Yol İkonu Gönder [Shortcut icon on the desk in the file name to send]", OnAction:="MasaÜstüneDosyaKısaYolİkonuGönder"
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 KoşulluAltToplam() 'SubTotal

On Error Resume Next
'ALTTOPLAM(işlev_sayısı, başv1, başv2, ...)
'işlev_sayısı
            'A)Gizli Değerleri Kapsar
'1 ORTALAMA
'2 SAY
'3 DOLUSAY
'4 MAK
'5 MİN
'6 ÇARPIM
'7 STDSAPMA
'8 STDSAPMAS
'9 TOPLA
'10 VAR
'11 VARS
'B)Gizli Değerleri Yok Sayar
'101 ORTALAMA
'102 SAY
'103 DOLUSAY
'104 MAK
'105 MİN
'106 ÇARPIM
'107 STDSAPMA
'108 STDSAPMAS
'109 TOPLA
'110 VAR
'111 VARS
'başv1, başv2, ...; alt toplamını almak istediğiniz 1 ile 29 arasındaki aralık veya başvurudur.
HesTipNo = VBA.InputBox("İşlev No Giriniz" & vbCrLf, "[PBİD®] Alt Toplam [SubTotal] İşlev No", 9)
Set SubTotalAlanı = Application.Selection
AltToplam = Application.WorksheetFunction.Subtotal(HesTipNo, SubTotalAlanı)
If VBA.Err.Number > 0 Then
MsgBox "Sayı değeri olmayan bir veri tabanında AltToplam [SubTotal] işlemi yaptınız!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Alt Toplam SubTotal İşlemi..."
Else
MsgBox Application.WorksheetFunction.Subtotal(HesTipNo, SubTotalAlanı)
End If
End Sub
Sub TekrarlananVerileriBoyama()
'Dublicate Data Painting

On Error Resume Next
For i = 1 To [A65536].End(xlUp).row
If WorksheetFunction.CountIf(Columns(1), Cells(i, 1)) = 1 Then
Cells(i, 1).Interior.ColorIndex = xlNone
ElseIf WorksheetFunction.CountIf(Columns(1), Cells(i, 1)) = 0 Then
Cells(i, 1).Interior.ColorIndex = 36
Else
Cells(i, 1).Interior.ColorIndex = 37
End If
Next
End Sub
Sub TekrarlananVeriyiSatırOlarakSilme()
'Remove Duplicates

On Error Resume Next
Application.Cells.Sort Key1:=Range("A1")
Adet = Application.ActiveSheet.UsedRange.Rows.count
No = 1
For i = Adet To 2 Step -1
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Rows(i).Delete
No = No + 1
Else
Cells(i, 3).Value = No
No = 1
End If
Next i
Cells(1, 3).Value = No
End Sub
Sub HücreyeFormülEklemek()
'Add Formule to Range

On Error Resume Next
Set Hücre = ActiveSheet.Range(ActiveWindow.Selection.Address)
Hücre.ClearContents
FormülVerisi = InputBox("Aktif hale gelmesini istediğiniz formülü yazınız" & vbCrLf & vbCrLf & "Mustfa ULUSARAÇ 01ulusarac@superonline.com", "[PBİD®] Hücreye Formül Yazmak...", "")
If Not FormülVerisi = "" Then
For i = 1 To Hücre.Cells.count
If Hücre.Cells(i).HasFormula Then
Formül = Hücre.Cells(i).Formula
Formül = "=(" & VBA.Mid(Formül, 2, 500) & ")"
Formül = Formül & FormülVerisi
Hücre.Cells(i).Formula = Formül
Else
Formül = "=" & Hücre.Cells(i).Value & FormülVerisi
Hücre.Cells(i).Formula = Formül
End If
Next i
End If
End Sub
Sub İkiTarihArasındaGeçenGünSayısı()
'Date diffarence

On Error Resume Next
ActiveCell.Value = VBA.CLng(VBA.CDate(ActiveCell.Offset(0, -1))) - VBA.CLng(VBA.CDate(ActiveCell.Offset(0, -2)))
End Sub
Sub TamSayıEldeEtmek()

On Error Resume Next
Dim Sayı As Double
Sayı = ActiveCell.Value
ActiveCell = "=INT(sayı)" '1. alternatif
ActiveCell = "=CEILING(sayı,1)" '2. alternatif
End Sub

'DİĞER ÖZEL MAKROLAR


Sub AğPrinterdeYazdırma()
'PrintToNetworkPrinterExample

On Error GoTo Hata
AğPrinteri = AğPrinterYoklama("HP LaserJet 8100 Series PCL123456")
If (VBA.Len(AğPrinteri) > 0) Then
PCPrinteri = Application.ActivePrinter
Application.ActivePrinter = AğPrinteri
Worksheets(1).PrintOut
Application.ActivePrinter = PCPrinteri
End If
Exit Sub
Hata:
AğPrinteri = ""
End Sub
Function AğPrinterYoklama(AğPrinterAdı) As String '
GetFullNetworkPrinterName

PCPrinterAdı = Application.ActivePrinter
Yoklama = 0
Do (While Yoklama <>
GörevliPrinterAdı = AğPrinterAdı & " on Ne" & Format(Yoklama, "00") & ":"
             On Error Resume Next
            Application.ActivePrinter = GörevliPrinterAdı
            On Error GoTo 0
            If Application.ActivePrinter = GörevliPrinterAdı Then
AğPrinterYoklama = GörevliPrinterAdı
Yoklama = 100
End If
Yoklama = Yoklama + 1
Loop
Application.ActivePrinter = PCPrinterAdı
End Function
Public Sub mp3Başlat() '
mp3Play

On Error Resume Next
mp3Dosya = VBA.Chr$(34) & "C:\Documents and Settings\PC\Desktop\BLOGSPOT\TSM.mp3" & VBA.Chr$(34)
If mp3Çalar = True Then
Call mciSendString("Stop MM", 0&, 0&, 0&)
Call mciSendString("Close MM", 0&, 0&, 0&)
Call mciSendString("Open " & mp3Dosya & " Alias MM", 0&, 0&, 0&)
Call mciSendString("Play MM", 0&, 0&, 0&)
Else
Call mciSendString("Open " & mp3Dosya & " Alias MM", 0&, 0&, 0&)
Call mciSendString("Play MM", 0&, 0&, 0&)
mp3Çalar = True
End If
End Sub
Public Sub mp3Durudur()
'mp3Stop

On Error Resume Next
If mp3Çalar = False Then Exit Sub
Call mciSendString("Stop MM", 0&, 0&, 0&)
Call mciSendString("Close MM", 0&, 0&, 0&)
End Sub
Sub ÇalışmaKitabınaÖzelMenüKur()
'Make Special CB Menu

For Each CB In Application.CommandBars
If CB.Type = msoBarTypeMenuBar And CB.Name = "AnaMenü" Then
CB.Delete
End If
Next CB
Set ÖzelCB = Application.CommandBars.Add(Name:="AnaMenü", Position:=msoBarTop, MenuBar:=True, Temporary:=True)
With ÖzelCB
.Protection = msoBarNoMove
.Protection = msoBarNoChangeDock
.Protection = msoBarNoChangeVisible
.Protection = msoBarNoCustomize
.Protection = msoBarNoVerticalDock
.Visible = True
.Enabled = True
End With
Set ÖzelAltMenü = ÖzelCB.Controls.Add(Type:=msoControlPopup)
With ÖzelAltMenü
.Caption = "Menü &1"
Set ÖzelMenüDüğmesi = .Controls.Add(ID:=247)
With ÖzelMenüDüğmesi
.Style = msoButtonCaption
End With
Set ÖzelMenüDüğmesi = .Controls.Add(ID:=109)
With ÖzelMenüDüğmesi
.Style = msoButtonAutomatic
End With
Set ÖzelMenüDüğmesi = .Controls.Add(ID:=4)
With ÖzelMenüDüğmesi
.BeginGroup = True
.Style = msoButtonAutomatic
End With
End With
Set ÖzelAltMenü = ÖzelCB.Controls.Add(Type:=msoControlPopup)
With ÖzelAltMenü
.Caption = "Menü &2"
Set ÖzelMenüDüğmesi = .Controls.Add(ID:=1)
With ÖzelMenüDüğmesi
.Caption = "Menü 2.&1"
.OnAction = "Menü2_1"
.Style = msoButtonCaption
End With
Set ÖzelMenüDüğmesi = .Controls.Add(ID:=1)
With ÖzelMenüDüğmesi
.BeginGroup = True
.FaceId = 239
.Caption = "Menü 2.&2"
.OnAction = "Menü2_2"
.Style = msoButtonIconAndCaption
End With
End With
End Sub
Sub Menü2_1()

On Error Resume Next
MsgBox "Menü2.1" & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] Özel Menü Komutu"
End Sub
Sub Menü2_2()

On Error Resume Next
MsgBox "Menü2.2" & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] Özel Menü Komutu"
End Sub
Sub ÇalışmaKitabındakiÖzelMenüyüSil()
'Delete Special CB Menu

On Error Resume Next
Application.CommandBars("AnaMenü").Delete
On Error GoTo 0
End Sub
Sub TakvimMesajı()
'Calendar Message

On Error Resume Next
Dim Gün, Tarih, Saat
Dim Sürücü, Mesaj As Integer
Gün = VBA.WeekdayName(VBA.Weekday(VBA.Date, VBA.vbMonday))
Tarih = VBA.Day(Date) & ". " & VBA.MonthName(VBA.Month(VBA.Date)) & " " & VBA.Year(VBA.Date)
Saat = VBA.Time
Set Sürücü = VBA.CreateObject("WScript.Shell")
Mesaj = Sürücü.Popup(Gün & VBA.Chr(13) & Tarih & VBA.Chr(13) & Saat, 3, "[PBİD®] Mesaj Örneği")
End Sub
Sub ÇokluMesajGöndermek()
'MultiEmail

On Error Resume Next
Adet = Cells(65536, 1).End(xlUp).row
For i = 1 To Adet
MesajTarihi = Application.Cells(i, 1)
If VBA.Err.Number > 0 Then GoTo Devam
If MesajTarihi = VBA.Date Then
Set Program = New Outlook.Application
Set Mesaj = CreateItem(olMailItem)
With Mesaj
.To = Cells(i, 2).Text
.Subject = MesajTarihi & "Bilgisi"
.Body = "[PBİD®] Mesaj içeriği BLOGSPOT.xls Dosyasındandır."
.Save
.Send
End With
Set Mesaj = Nothing
Set Program = Nothing
End If
Devam:
VBA.Err.Number = 0
Next i
End Sub
Sub MasaÜstüneDosyaKısaYolİkonuGönder()
'Shortcut icon on the desk in the file name to send

On Error Resume Next
Call KısaYolİkonuYapmak(ThisWorkbook.FullName)
End Sub
Function KısaYolİkonuYapmak(strFullFilePathName As String) As Long

On Error GoTo Hata
Set KısaYol = CreateObject("wscript.Shell")
DosyaAdı = Dir(strFullFilePathName)
Yol = Left(strFullFilePathName, Len(strFullFilePathName) - Len(DosyaAdı))
If Not Len(DosyaAdı) = 0 Then
MasaÜstüYolu = KısaYol.SpecialFolders.item("Desktop")
Set İkon = KısaYol.CreateShortcut(MasaÜstüYolu & "\" & DosyaAdı & ".lnk")
With İkon
.TargetPath = KısaYol.ExpandEnvironmentStrings(strFullFilePathName)
.WorkingDirectory = KısaYol.ExpandEnvironmentStrings(Yol)
.WindowStyle = 4
.IconLocation = KısaYol.ExpandEnvironmentStrings(Application.Path & "\excel.exe , 0")
.Save
End With
KısaYolİkonuYapmak = 1
Else
KısaYolİkonuYapmak = 0
End If
Devam:
Set KısaYol = Nothing
Exit Function
Hata:
KısaYolİkonuYapmak = -1
Resume Devam
End Function

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

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