Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ocak 2006 Cuma

To Use CommandBars(1) on UserForm1




'UserForm1

Private i As Single, ii As Single, iii As Single

Private ActiveX(3) As Control
Private ActiveXKontrol(3) As String
Private Menü As CommandBar
Private Ana As CommandBarControl
Private Alt As CommandBarControl
Private Tali As CommandBarControl
Private IDTip As Variant
Private IDNo As Variant
Private IDMenü As CommandBar
Private IDKontrol As CommandBarControl
Private ListeKontrol As Double

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD ®] CommandBars(1) Seçenekleri"
.Height = 162
.Width = 282
End With
ActiveXKontrol(1) = "Forms.ListBox.1"
Set ActiveX(1) = Me.Controls.Add(ActiveXKontrol(1))
With ActiveX(1)
.Name = "UserForm1"
.Top = 6
.Left = 6
.Width = 264
.Height = 108
.ColumnCount = 3
.ColumnWidths = "180;36;36"
.BackColor = &H80000018
.SpecialEffect = 3
.ControlTipText = "PopUp Menüden Çıkmak İçin Esc Düğmesine Basınız"
End With
ActiveXKontrol(2) = "Forms.Label.1"
Set ActiveX(2) = Me.Controls.Add(ActiveXKontrol(2))
With ActiveX(2)
.Top = 114
.Left = 6
.Width = 216
.Height = 18
.Caption = " Seçilen Menü ID No"
.SpecialEffect = 3
.BackColor = &H80000018
End With
ActiveXKontrol(3) = "Forms.Label.1"
Set ActiveX(3) = Me.Controls.Add(ActiveXKontrol(3))
With ActiveX(3)
.Top = 114
.Left = 222
.Width = 48
.Height = 18
.Caption = ""
.SpecialEffect = 3
.BackColor = &H80000018
.TextAlign = 2
End With
Set Menü = Application.CommandBars(1)
i = 0
For Each Komut1 In Menü.Controls
i = i + 1
Set Ana = Menü.Controls(i)
Komut = Ana.Caption
ActiveX(1).AddItem Komut
ActiveX(1).List(ActiveX(1).ListCount - 1, 1) = Ana.Type
ActiveX(1).List(ActiveX(1).ListCount - 1, 2) = Ana.ID
If Ana.Type = 10 Then
ii = 0
For Each Komut2 In Ana.Controls
ii = ii + 1
Set Alt = Ana.Controls(ii)
Komut2 = Alt.Caption
ActiveX(1).AddItem " " & Komut2
ActiveX(1).List(ActiveX(1).ListCount - 1, 1) = Alt.Type
ActiveX(1).List(ActiveX(1).ListCount - 1, 2) = Alt.ID
If Alt.Type = 10 Then
iii = 0
For Each Komut3 In Alt.Controls
iii = iii + 1
Set Tali = Alt.Controls(iii)
Komut3 = Tali.Caption
ActiveX(1).AddItem " " & Komut3
ActiveX(1).List(ActiveX(1).ListCount - 1, 1) = Tali.Type
ActiveX(1).List(ActiveX(1).ListCount - 1, 2) = Tali.ID
                                               Next Komut3
End If
Next Komut2
End If
Next Komut1
ListeKontrol = 1
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Do While ListeKontrol = 1
If ActiveX(1).ListIndex <> -1 Then
IDTip = ActiveX(1).List(ActiveX(1).ListIndex, 1)
IDNo = ActiveX(1).List(ActiveX(1).ListIndex, 2)
If (ActiveX(3).Caption <> IDNo) Then
ActiveX(3).Caption = IDNo
Set IDMenü = Application.CommandBars.Add("", msoBarPopup, , True)
Set IDKontrol = IDMenü.Controls.Add(IDTip, IDNo, , , True)
IDMenü.ShowPopup
End If
End If
DoEvents
Loop
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
ListeKontrol = 0
Unload Me
End Sub

10 Ocak 2006 Salı

Normal and Union Character Set of Key Codes



'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Name: VBA, Description: Visual Basic For Applications, Full Path: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'Name: Excel, Description: Microsoft Excel 11.0 Object Library, Full Path: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'Name: stdole, Description: OLE Automation, Full Path: C:\WINDOWS\system32\stdole2.tlb
'Name:
Office, Description: Microsoft Office 11.0 Object Library, Full Path: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, Full Path: C:\WINDOWS\system32\FM20.DLL
'B) UserForm1'e Eklenen Araçlar (Add Tools)
'Label1, Label2, Label3, Label4, Label5, Label6, Label7, ListBox1, CommandButton1
Option Explicit
Dim i As Single, ii As Single, No As Double
Dim Bellek(0 To 65535, 0 To 6)
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®]The Chr Table Make"
Call EkranDüzenle
End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 312
.Width = 6 + 54 * 7 + 12 + 12
.BackColor = vbWhite
For i = 1 To 7
With Me("Label" & i)
.BackStyle = fmBackStyleOpaque
.BackColor = &H80000013
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.Height = 12
.Width = 54
.Top = 6
.Font.Bold = False
.ForeColor = vbBlue
.TextAlign = fmTextAlignCenter
.Left = (i - 1) * 54 + 6
End With
Next i
Label1.Caption = "Code No"
Label2.Caption = "Chr(255)"
Label3.Caption = "Chr$(255)"
Label4.Caption = "ChrB(255)"
Label5.Caption = "ChrB$(255)"
Label6.Caption = "ChrW(65535)"
Label7.Caption = "ChrW$(65535)": Label7.Width = 54 + 12
With ListBox1
.BackColor = &H80000013
.BorderStyle = fmBorderStyleNone
.ColumnCount = 7
.ColumnWidths = "54;54;54;54;54;54;54"
.SpecialEffect = fmSpecialEffectEtched
.Font.Bold = False
.ForeColor = vbBlue
.Font.Size = 10
.TextAlign = fmTextAlignLeft
.Top = 18
.Width = 390
.Height = 241.35
End With
With CommandButton1
.Left = 6
.Top = ListBox1.Top + ListBox1.Height + 6
.Width = ListBox1.Width
.Height = 18
.Caption = "The Chr Table Make"
End With
DoEvents
End With
End Sub
Private Sub CommandButton1_Click()

On Error Resume Next
For i = 0 To 65535
Bellek(i, 0) = i
Bellek(i, 1) = VBA.Chr(i): If VBA.Err.Number > 0 Then Bellek(i, 1) = "NA": VBA.Err.Number = 0
Bellek(i, 2) = VBA.Chr$(i): If VBA.Err.Number > 0 Then Bellek(i, 2) = "NA": VBA.Err.Number = 0
Bellek(i, 3) = VBA.ChrB(i): If VBA.Err.Number > 0 Then Bellek(i, 3) = "NA": VBA.Err.Number = 0
Bellek(i, 4) = VBA.ChrB$(i): If VBA.Err.Number > 0 Then Bellek(i, 4) = "NA": VBA.Err.Number = 0
Bellek(i, 5) = VBA.ChrW(i): If VBA.Err.Number > 0 Then Bellek(i, 5) = "NA": VBA.Err.Number = 0
Bellek(i, 6) = VBA.ChrW$(i): If VBA.Err.Number > 0 Then Bellek(i, 6) = "NA": VBA.Err.Number = 0
Next i
ListBox1.List() = Bellek()
Call Ascii255Karakter
End Sub
Private Sub Ascii255Karakter()

On Error Resume Next
If Sheets(1).Name = "CodeNoChr" Then
Sheets("CodeNoChr").Select
Cells.Select
Selection.Delete Shift:=xlUp
Else
Worksheets.Add Before:=Sheets(1)
Sheets(1).Name = "CodeNoChr"
End If
For i = 2 To 26
For ii = 1 To 11
No = (i - 1) - 1 + (ii - 1) * 25 + 1
If No > 255 Then
Cells(i, ((ii - 1) * 2) + 1).Value = ""
Cells(i, ((ii - 1) * 2) + 2).Formula = ""
Else
If i = 2 Then Cells((i - 1), ((ii - 1) * 2) + 1).Value = "Code No"
If i = 2 Then Cells((i - 1), ((ii - 1) * 2) + 2).Value = "Chr"
Cells(i, ((ii - 1) * 2) + 1).Value = No
Cells(i, ((ii - 1) * 2) + 2).Formula = VBA.Chr(No)
End If
Next ii
Next i
Call Boya
End Sub
Private Sub Boya()

On Error Resume Next
With Range("A1:V1")
.RowHeight = 30
.Font.ColorIndex = 2
With .Interior
.ColorIndex = 5
.Pattern = xlSolid
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
With Range("A2:V26")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
With .Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Bold = False
End With
.Interior.Color = VBA.RGB(200, 255, 255)
End With
Range("A1").Select
Columns("A:V").Columns.AutoFit
End Sub

1 Ocak 2006 Pazar

Full Fields On The Page To Print a Single Template



'ThisWorkBook.Sheets("BlogArşivi") Module

Private Sub CommandButton1_Click()
On Error Resume Next
YGSA = "BlogArşivi"
YGAKA = 12
YGASA = 25
YGAKT = 3
YGAST = 20
SSA = 5
SKA = 2
LH = ""
CH = ""
RH = ""
LF = ""
CF = ""
RF = ""
LM = 0.5 * Sabit
RM = 0.5 * Sabit
TM = 1 * Sabit
BM = 0.5 * Sabit
HM = 0 * Sabit
FM = 0 * Sabit
PH = 0
PG = 0
PC = xlPrintNoComments
PQ = 600
CHo = 1
CVe = 1
Ort = 2
Dft = False
PS = xlPaperA4
FPN = xlAutomatic
Ord = xlDownThenOver
BW = False
Zm = False
FPW = 1
FPT = 1
PEr = xlPrintErrorsDisplayed
Cops = 1
Coll = 1
YazdırmaAlanıTesbiti YGSA, SKA, SSA, YGAKA, YGASA, YGAKT, YGAST
End Sub

'Module1

Option Explicit
Dim i As Single, ii As Single
Public Const Sabit = (0.984251968503937 / 2.5)
Public xK(2) As Double, yK(2) As Double
' x ve y Koordinatları
Public YGAA As Range
'Yazıcıya Gönderilecek Alanın Adresi
Public YGATD As Double
'Yazıcıya Gönderilecek Alanın Toplam Değeri
Public YGSA As String
'Yazıcıya Gönderilecek Sayfa Adı; Default= PERSONAL
Public YGAKA As Double
'Yazıcıya Gönderilen Alanın Kolon Adedi; Default= PERSONEL
Public YGASA As Double
'Yazıcıya Gönderilen Alanın Satır Adedi; Default= PERSONEL
Public YGAKT As Double
'Yazıcıya Gönderilen Alanın Kolon Tekrarı; Default= PERSONEL
Public YGAST As Double
'Yazıcıya Gönderilen Alanın Satır Tekrarı; Default= PERSONEL
Public SKA As Double
'Sabit Kolon Adedi
Public SSA As Double
'Sabit Satır Adedi
Public PTR As String
'PrintTitleRows; Default= 0

Public PTC As String 'PrintTitleColumns; Default= 0
Public PA As String 'PrintArea; Default= PERSONAL
Public LH As Variant
'LeftHeader; Default= ""
Public CH As Variant
'CenterHeader; Default= ""

Public RH As Variant 'RightHeader; Default= ""
Public LF As Variant 'LeftFooter; Default= ""
Public CF As Variant 'CenterFooter; Default= ""
Public RF As Variant
'RightFooter; Default= ""
Public LM As Double
'LeftMargin; Default= 0.748031496062992 [1,9]
Public RM As Double
'RightMargin; Default= 0.748031496062992 [1,9]

Public TM As Double 'TopMargin; Default= 0.984251968503937 [2,5]
Public BM As Double 'BottomMargin; Default= 0.984251968503937 [2,5]
Public HM As Double 'HeaderMargin; Default= 0.511811023622047 [1,3]
Public FM As Double 'FooterMargin; Default= 0.511811023622047 [1,3]
Public PH As Boolean 'PrintHeadings; Default= False [0]
Public PG As Boolean 'PrintGridlines; Default= False [0]
Public PC As Variant
'PrintComments; Default= xlPrintNoComments
Public PQ As Double
'PrintQuality; Default= 300
Public CHo As Boolean
'CenterHorizontally; Default= False [0]

Public CVe As Boolean 'CenterVertically; Default= False [0]
Public Ort As Variant
'Orientation; Default= xlPortrait [1], xlLandsCape [2]

Public Dft As Boolean 'Draft; Default= False [0]
Public PS As Variant
'PaperSize; Default= xlLetter], xlLegal,xlPaperExecutive, xlPaperA4, xlPaperA3

Public FPN As Variant 'FirstPageNumber; Default= xlAutomatic
Public Ord As Variant
'Order; Default= xlDownThenOver

Public BW As Boolean 'BlackAndWhite; Default= False
Public Zm As Variant
'Zoom; Default= 100

Public FPW As Double 'FitToPagesWide; Default= 1
Public FPT As Double 'FitToPagesTall; Default= 1
Public PEr As Variant 'PrintErrors; Default= xlPrintErrorsDisplayed
Public Cops As Double
'Print Copies

Public Coll As Boolean 'Print Collate
Public Function YazdırmaAlanıTesbiti(YGSA, SKA, SSA, YGAKA, YGASA, YGAKT, YGAST)
On Error Resume Next
With Sheets(YGSA)
PTC = "$A:" & VBA.Left(Cells(1, SKA).Address, VBA.Len(Cells(1, SKA).Address) - 2)
PTR = "$1:$" & SSA
With .PageSetup
.PrintTitleRows = PTR
.PrintTitleColumns = PTC
.LeftHeader = LH
.CenterHeader = CH
.RightHeader = RH
.LeftFooter = LF
.CenterFooter = CF
.RightFooter = RF
.LeftMargin = Application.InchesToPoints(LM)
.RightMargin = Application.InchesToPoints(RM)
.TopMargin = Application.InchesToPoints(TM)
.BottomMargin = Application.InchesToPoints(BM)
.HeaderMargin = Application.InchesToPoints(HM)
.FooterMargin = Application.InchesToPoints(FM)
.PrintHeadings = PH
.PrintGridlines = PG
.PrintComments = PC
.PrintQuality = PQ
.CenterHorizontally = CHo
.CenterVertically = CVe
.Orientation = Ort
.Draft = Dft
.PaperSize = PS
.FirstPageNumber = FPN
.Order = Ord
.BlackAndWhite = BW
.Zoom = Zm
.FitToPagesWide = FPW
.FitToPagesTall = FPT
.PrintErrors = PEr
End With
For i = 1 To YGAKT
For ii = 1 To YGAST
xK(1) = (SSA + 1) + (ii - 1) * YGASA
yK(1) = (SKA + 1) + (i - 1) * YGAKA
xK(2) = xK(1) + YGASA - 1
yK(2) = yK(1) + YGAKA - 1
Set YGAA = Range(Cells(xK(1), yK(1)), Cells(xK(2), yK(2)))
YGATD = Application.WorksheetFunction.Sum(YGAA)
If (YGATD > 0) Then
PA = YGAA.Address
.PageSetup.PrintArea = PA
.PrintOut Copies:=Cops, Collate:=Coll
End If
Next ii
Next i
End With
End Function

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