Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2003 Cumartesi

Data Base Control on UserForm



'UserForm1

Option Explicit
Dim Bakılan As Range
Dim No As Double
Dim VeriTabanı, SatırSayısı, SonSatır

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Data Base Control on UserForm..."
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Set VeriTabanı = Application.Cells(1, 1).CurrentRegion: Label1.Caption = " " & VeriTabanı.Address
SatırSayısı = VeriTabanı.Rows.Count: Label2.Caption = " " & SatırSayısı
SonSatır = SatırSayısı + 1: Label3.Caption = " " & SonSatır
Call DoluBoşKayıtBilgisi
Cells(SonSatır, 1).Select
End Sub
Private Sub DoluBoşKayıtBilgisi()
On Error Resume Next
No = 0
For Each Bakılan In VeriTabanı
If IsEmpty(Bakılan) Then
No = No + 1
ComboBox1.AddItem Bakılan.Address
End If
If Not IsEmpty(Bakılan) Then
'No = No + 1
'ComboBox1.AddItem Bakılan.Address
End If
Next Bakılan
Label4.Caption = " " & No
End Sub

10 Aralık 2003 Çarşamba

Sheet PopUp [Page Select] Menu



'Module1

Option Explicit
Dim CB As CommandBar, i As Integer
Dim CBB As CommandBarButton

Sub Auto_Open()
On Error Resume Next
PopUpMenu
End Sub
Sub PopUpMenu()
On Error Resume Next
Set CB = Application.CommandBars("Cell")
For i = CB.Controls.Count To 0 Step -1
CB.Controls(i).Delete
Next i
With CB
For i = 1 To Sheets.Count
With .Controls.Add(Type:=msoControlButton)
.OnAction = "SayfaGoster"
.FaceId = 230
.Caption = Sheets(i).Name
End With
Next i
End With
Set CB = Nothing
End Sub
Sub SayfaGoster()
On Error Resume Next
Set CBB = Application.CommandBars.ActionControl
Sheets(CBB.Caption).Select
Set CBB = Nothing
End Sub
Sub Auto_Close()
On Error Resume Next
Application.CommandBars("Cell").Reset
End Sub

1 Aralık 2003 Pazartesi

Multi Line Select on Sheet



'Module1

Option Explicit
Dim i As Integer
Dim İlk, Son As Double
Dim Satır As Variant

Sub ÇokluSatırSeç()
On Error Resume Next
İlk = InputBox("İlk Satır No:", "[PBİD®]Çoklu Satır Seçimi")
Son = InputBox("Son Satır No:", "[PBİD®]Çoklu Satır Seçimi")
Satır = ""
For i = İlk To Son Step 2
Satır = Satır + Trim(Str(i)) + ":" + Trim(Str(i)) + ","
Next i
Satır = Left(Satır, Len(Satır) - 1)
Range(Satır).Select
End Sub

20 Kasım 2003 Perşembe

UserForm Create With Module Code Editors



'Module1

Option Explicit
Dim Ekran
Dim i, ii, Adet, ÜstPoz, SolPoz As Integer
Dim NewF1 As MSForms.Frame
Dim NewF2 As MSForms.Frame
Dim NewL1 As MSForms.Label
Dim NewOB1 As MSForms.OptionButton
Dim NewCB1 As MSForms.CommandButton
Dim NewCB2 As MSForms.CommandButton
Public UserFormÖrneği, Tercih As Variant

Sub UserFormYap()
On Error Resume Next
Adet = Range("İlAdları").Count
ReDim Hafıza(1 To Adet)
For i = 1 To Adet
Hafıza(i) = Range("İlAdları").Cells(i, 1) 'İlAdları VeriTabanı sayfasının C2:C100 alanı olarak tanımlanmıştır.
Next i
Tercih = UserFormYapıcı(Hafıza, "[PBİD®] UserForm Create With Module Code Editors...")
If Tercih = True Then
[F2] = Hafıza(Tercih)
Else
[F2] = ""
End If
End Sub
Function UserFormYapıcı(Bilgi, Başlık)
SolPoz = 6: ÜstPoz = 6: i = 0: ii = 0: Adet = 0
Application.VBE.MainWindow.Visible = False
Set Ekran = ThisWorkbook.VBProject.VBComponents.Add(3)
'0= vbext_ct_ActiveXDesigner, 1= vbext_ct_ClassModule, 2= vbext_ct_Document, 3= vbext_ct_MSForm, 4= vbext_ct_StdModule
With Ekran
.Properties("Caption") = Başlık
.Properties("Width") = 240
.Properties("BackColor") = &H80000016
Set NewF1 = .Designer.Controls.Add("Forms.Frame.1")
With NewF1
.Caption = "İl Veri Tabanı"
For i = LBound(Bilgi) To UBound(Bilgi)
Set NewOB1 = .Controls.Add("Forms.OptionButton.1")
With NewOB1
.Caption = Bilgi(i)
.Width = 72
.Height = 15
.Left = 6
.Top = ÜstPoz
.Tag = i
.AutoSize = False
End With
ÜstPoz = ÜstPoz + 14
Next i
.ForeColor = vbBlue
.Top = 6
.Left = 6
.Height = 70
.Width = 240 - (6 + 6 + 6)
.ScrollBars = 2
.ScrollHeight = ((i * 14) - 6)
ÜstPoz = .Top + .Height
End With
Set NewCB1 = .Designer.Controls.Add("forms.CommandButton.1")
With NewCB1
.Caption = "Vazgeç"
.Height = 18
.Width = 72
.Left = 6
.Top = ÜstPoz + 6
SolPoz = .Left + .Width + 6
End With
Set NewCB2 = .Designer.Controls.Add("forms.CommandButton.1")
With NewCB2
.Caption = "Tamam"
.Height = 18
.Width = 72
.Left = SolPoz
.Top = ÜstPoz + 6
ÜstPoz = .Top + .Height
End With
Set NewF2 = .Designer.Controls.Add("Forms.Frame.1")
With NewF2
.Caption = ""
.Top = ÜstPoz + 6
.Left = 6
.Width = .Width + 6
.Height = 2
.SpecialEffect = fmSpecialEffectEtched
ÜstPoz = .Top + 6 + 2
End With
Set NewL1 = Ekran.Designer.Controls.Add("forms.Label.1")
With NewL1
.Caption = "Mustafa ULUSARAÇ 01ulusarac@superonline.com"
.Height = 24
.Width = 240 - (6 + 6)
.Left = 6
.Top = ÜstPoz
.ForeColor = vbBlue
.TextAlign = fmTextAlignCenter
ÜstPoz = .Top + 24 + 24
End With
.Properties("Height") = ÜstPoz
With .CodeModule
ii = .CountOfLines
.InsertLines ii + 1, "Option Explicit"
.InsertLines ii + 2, "Dim i, Adet As Integer"
.InsertLines ii + 3, "Dim Ctl as Control"
.InsertLines ii + 4, "Private Sub UserForm_Initialize()"
.InsertLines ii + 5, " On Error Resume Next"
.InsertLines ii + 6, " Adet = Range(""İlAdları"").Count"
.InsertLines ii + 7, " For i = 1 To Adet"
.InsertLines ii + 8, " if [F2] = me(""OptionButton"" & i ).Caption Then me(""OptionButton"" & i ).Value=True"
.InsertLines ii + 9, " Next i"
.InsertLines ii + 10, "End Sub"
.InsertLines ii + 11, "Sub CommandButton1_Click()"
.InsertLines ii + 12, " UserFormÖrneği=False"
.InsertLines ii + 13, " Unload Me"
.InsertLines ii + 14, "End Sub"
.InsertLines ii + 15, "Sub CommandButton2_Click()"
.InsertLines ii + 16, " Dim ctl"
.InsertLines ii + 17, " UserFormÖrneği = False"
.InsertLines ii + 18, " For Each Ctl In Me.Controls"
.InsertLines ii + 19, " If (Ctl.Tag <> """") Then If Ctl Then UserFormÖrneği = Ctl.Tag"
.InsertLines ii + 20, " Next Ctl"
.InsertLines ii + 21, " Unload Me"
.InsertLines ii + 22, "End Sub"
End With
End With
VBA.UserForms.Add(Ekran.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=Ekran
UserFormYapıcı = UserFormÖrneği
End Function

10 Kasım 2003 Pazartesi

UserForm QueryClose True

'UserForm1
Private Sub CommandButton1_Click()
On Error Resume Next
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
If CloseMode = vbFormControlMenu Then Cancel = True
End Sub

1 Kasım 2003 Cumartesi

UserForm Object Controls



'UserForm1

Option Explicit
Dim Ctr As Control
Dim Say As Integer
Dim Mesaj As String

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] UserForm Object Controls..."
Label1.Caption = "": Label2.Caption = ""
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Say = 0: Mesaj = ""
For Each Ctr In Me.Controls
If VBA.TypeName(Ctr) = "CheckBox" Then
If Ctr.Value Then
Say = Say + 1
Mesaj = Mesaj & Ctr.Name & vbCr
End If
End If
Next Ctr
Label1.Caption = Say
Label2.Caption = "adet CheckBox işaretli."
End Sub

20 Ekim 2003 Pazartesi

SaveAs Password

'Module1

Sub SaveAs_Password()
On Error GoTo 20
10
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Password:="0123456789"
ActiveWindow.Close
Application.DisplayAlerts = True
GoTo 10
20
Exit Sub
End Sub

10 Ekim 2003 Cuma

Password With InputBox


'Module1

Dim Şifre, Deneme As Long

Sub ŞifreSorgusu()
On Error Resume Next
60 Şifre = InputBox("Lütfen şifreyi giriniz!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", "[PBİD®] Şifre Sorgusu")
If Şifre = "0123456789" Then
Range("A1").Select
Exit Sub
Else
MsgBox "Yanlış şifre girdiniz!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat..."
End If
Deneme = MsgBox("Yeniden denemek ister misiniz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbYesNo, "[PBİD®]Lütfen Dikkat...")
If Deneme = 6 Then
GoTo 60
Else
Exit Sub
End If
End Sub

1 Ekim 2003 Çarşamba

Timing Control




'UserForm1

'Add Tools on UserForm1: label1
Option Explicit
Dim Kalan As Double
Dim Bitiş As Date

Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Timing on UserForm Components..."
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
Application.OnTime VBA.Now + VBA.TimeValue("00:00:30"), "ZamanlanmışKomut"
Bitiş = VBA.Now + VBA.TimeValue("00:00:30")
Do
Kalan = VBA.Round((Bitiş - VBA.Now) * 100000, 0)
Label1.Caption = Kalan & " saniye içinde form kapanacaktir!"
DoEvents
Loop
End Sub

'Module1

Option Explicit

Sub ZamanlanmışKomut()

On Error Resume Next
MsgBox "Be closed within 30 seconds." & vbCrLf & vbCrLf& "Mustafa ULUSARAÇ" & vbCrLf & "01ulusarac@superonline.com", vbInformation, "[PBİD®] Lütfen Dikkat!!!"
Unload UserForm1
End Sub


 

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 

1 Eylül 2003 Pazartesi

URL eMail




'UserForm1

'Add Tools on UserForm1: Label1
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim MyEmail, MySubject, MyBody, URL As Variant

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] URL eMail..."
Label1.Caption = 01ulusarac@superonline.com
End Sub
Private Sub Label1_Click()
On Error Resume Next
MyEmail = Label1.Caption
MySubject = "Merhaba...."
MyBody = "Bu bir deneme amaçlı elektronik postadır."
URL = "&Mailto:" & MyEmail & "&Subject=" & MySubject & "&Body=" & MyBody
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
Label1.Font.Underline = True
Label1.ForeColor = vbRed
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
Label1.Font.Underline = False
Label1.ForeColor = vbBlue
End Sub

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

 

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

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