Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

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

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