Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Mayıs 2008 Salı

Sheet PopUp [Special Control] Menu



'ThisWorkbook Module

Option Explicit

Private Sub Workbook_Activate()
On Error Resume Next
Application.CommandBars("[PBİD®] WorkSheets Menü").Visible = True
On Error GoTo 0
End Sub
Private Sub Workbook_Deactivate()
On Error Resume Next
Application.CommandBars("[PBİD®] WorkSheets Menü").Visible = False
On Error GoTo 0
End Sub
Private Sub Workbook_Open()
On Error Resume Next
Call PopUpMenüYap
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
PopUpMenüBoz
End Sub

'Module1

Option Explicit
Dim CB As CommandBar
Dim CBP As CommandBarPopup
Dim CBB As CommandBarButton

Sub PopUpMenüYap()
On Error GoTo Hata:
Call PopUpMenüBoz
Set CB = CommandBars.Add(Name:="[PBİD®] WorkSheets Menü", Position:=MsoBarPosition.msoBarFloating, temporary:=True)
With CB
Set CBP = .Controls.Add(Type:=msoControlPopup)
With CBP
.Caption = "[PBİD®] Popup 1"
.BeginGroup = True
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 1a"
.Style = msoButtonIconAndCaption
.BeginGroup = True
.OnAction = "Macro1a"
.FaceId = 45
End With
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 1b"
.Style = msoButtonIconAndCaption
.BeginGroup = False
.OnAction = "Macro1b"
.FaceId = 46
End With
End With
Set CBP = .Controls.Add(Type:=msoControlPopup)
With CBP
.Caption = "[PBİD®] Popup 2"
.BeginGroup = False
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 2a"
.Style = msoButtonIconAndCaption
.BeginGroup = True
.OnAction = "Macro2a"
.FaceId = 47
End With
Set CBB = .Controls.Add(Type:=msoControlButton)
With CBB
.Caption = "[PBİD®] Button 2b"
.Style = msoButtonIconAndCaption
.BeginGroup = False
.OnAction = "Macro2b"
.FaceId = 48
End With
End With
.Width = 240
.Top = 200
.Left = 200
.Visible = True
.Enabled = True
.Protection = msoBarNoResize
.RowIndex = 1
End With
Exit Sub
Hata:
Call PopUpMenüBoz
End Sub
Sub PopUpMenüBoz()
On Error Resume Next
CommandBars("[PBİD®] WorkSheets Menü").Delete
On Error GoTo 0
End Sub

10 Mayıs 2008 Cumartesi

Selection Shapes

 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If ActiveCell.Column = 2 Then
        With ActiveSheet
            .Unprotect
            If ActiveCell.Value <> "" Then
                .Shapes("Description").Cut
                '.DrawingObjects.Delete
                .Shapes.AddShape(msoShapeFlowchartDocument, 210, 140.25, 210, 116.25).Name = "Description"
                With .Shapes("Description")
                    .Top = ActiveCell.Offset(0, 1).Rows.Top
                    .Left = ActiveCell.Offset(1, 1).Rows.Left
                    .Fill.PresetGradient 1, 1, 4
                    .Line.Visible = msoFalse
                    .Shadow.Type = msoShadow21
                    .Reflection.Type = msoReflectionType5
                    With .Glow
                        .Color.ObjectThemeColor = msoThemeColorAccent1
                        .Color.TintAndShade = 0
                        .Color.Brightness = 0
                        .Transparency = 0.599999994
                        .Radius = 18
                    End With
                    With .TextFrame
                        .Characters.Text = Target.Value
                        With .Characters(Start:=1, Length:=5).Font
                            .Name = "Arial Narrow"
                            .FontStyle = "Bold"
                            .Size = 36
                            .Strikethrough = False
                            .Superscript = True
                            .Subscript = True
                            .OutlineFont = True
                            .Shadow = True
                            .Underline = xlUnderlineStyleNone
                            .ColorIndex = 36
                        End With
                        With .Characters(Start:=7, Length:=10).Font
                            .Name = "Arial Narrow"
                            .FontStyle = "Bold"
                            .Size = 36
                            .Strikethrough = False
                            .Superscript = True
                            .Subscript = True
                            .OutlineFont = True
                            .Shadow = True
                            .Underline = xlUnderlineStyleNone
                            .ColorIndex = 2
                        End With
                    End With
                End With
            Else
                .Shapes("Description").Cut
                '.DrawingObjects.Delete
            End If
            .Protect
        End With
    End If
End Sub
 

1 Mayıs 2008 Perşembe

Selection Interior



'Sheets("VeriTabanı") Module

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static ÖncekiHücre As Range
On Error Resume Next
If Target.Interior.ColorIndex = -4142 Then
Target.Interior.ColorIndex = 46
ÖncekiHücre.Interior.ColorIndex = xlColorIndexNone
Set ÖncekiHücre = Target
Else
ÖncekiHücre.Interior.ColorIndex = xlColorIndexNone
End If
End Sub



Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi