Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2005 Salı

MS Office 2003® CommandBar Buttons



'UserForm1

'AddTools on UserForm1: Frame1, Label1, ComboBox1, Label2, ComboBox2, ProgressBar1, ProgressBar2, Label3, CommandButton1, Image1, Label4
Option Explicit
Dim ÖzelMenü As Office.CommandBar
Dim ÖzelKomut As Office.CommandBarButton
Dim Resim As MSForms.Image, Resimlik(12000) As MSForms.Image
Dim i As Single, ii As Single, Sayaç As Single, No As Single
Dim Adet As Double, Başlama As Double, Bitiş As Double, Satır As Double, Sütun As Double

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] Micro Soft Office ® CommandBar Buttons..."
For i = 1 To 10033
ComboBox1.AddItem i
ComboBox2.AddItem i
Next i
ComboBox1.ListIndex = 0
ComboBox2.ListIndex = (ComboBox2.ListCount - 1)
Hata:
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Adet = Frame1.Controls.Count
If (Adet > 0) Then
Frame1.Controls.Clear
End If
Başlama = ComboBox1.Value
Bitiş = ComboBox2.Value
If (Bitiş > Başlama) Or (Başlama = Bitiş) Then
ResimlikDüzenle Başlama, Bitiş
Else
MsgBox "Bitiş; başlama numarasından küçük olamaz!" & vbCrLf & vbCrLf & "Musafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat"
End If
Hata:
End Sub
Private Function ResimlikDüzenle(ByVal Baş As Double, ByVal Son As Double)
On Error GoTo Hata:
No = Baş - 1
Sayaç = 0
Satır = Application.WorksheetFunction.RoundUp(((Son - Baş) + 1) / 16, 0)
Frame1.ScrollHeight = (24 * Satır + 6)
Set ÖzelMenü = Application.CommandBars.Add("", msoBarPopup, , True)
Set ÖzelKomut = ÖzelMenü.Controls.Add(1, , , , True)
For i = 1 To Satır
If i = Satır Then
Sütun = ((16 - ((Satır * 16) - Son)) - Baş + 1)
Else
Sütun = 16
End If
For ii = 1 To Sütun
No = No + 1
Sayaç = Sayaç + 1
Set Resimlik(No) = Me.Frame1.Controls.Add("Forms.Image.1")
With Resimlik(No)
ÖzelKomut.FaceId = No
.Name = No
.Picture = ÖzelKomut.Picture
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.Top = ((i - 1) * 24 + 6)
.Left = ((ii - 1) * 24 + 6)
.Width = 24
.Height = 24
.SpecialEffect = fmSpecialEffectEtched
.ControlTipText = No
End With
ProgressBar1.Value = ((ii / Sütun) * 100)
Label1.Caption = "%" & VBA.Round(100 * (Sayaç / ((Son - Baş) + 1)), 0)
DoEvents
Next ii
ProgressBar2.Value = ((i / Satır) * 100)
DoEvents
Next i
Exit Function
Hata:
MsgBox No
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