Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ekim 2007 Cumartesi

MS Office Excel® Dialogs




'UserForm1

Option Explicit
Dim x, y As Single
Dim Alan(1 To 137, 1 To 3)
Dim Sayfa, Adı

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Width = 354 + 6 + 6 + 6
.Height = 152
.Caption = "[PBİD®] Liste üzerinden dialog çağırınız..."
End With
For Each Sayfa In ThisWorkbook.Sheets
If Sayfa.Name = "Dialoglar" Then
Adı = Sayfa.Name
Exit For
Else
Adı = Sayfa.Name
End If
Next Sayfa
If Adı <> "Dialoglar" Then
ThisWorkbook.Sheets.Add Sheets(1), , 1
ThisWorkbook.Sheets(1).Name = "Dialoglar"
Call Excel_Dialog_Pencereleri
Else
Call Excel_Dialog_Pencereleri
End If
For x = 1 To 137
Alan(x, 1) = Sheets("Dialoglar").Cells(x + 1, 1).Value
Alan(x, 2) = Sheets("Dialoglar").Cells(x + 1, 2).Value
Alan(x, 3) = Sheets("Dialoglar").Cells(x + 1, 3).Value
Next x
With ListBox1
.Left = 6
.Top = 6
.Height = 118
.Width = 354
.ColumnCount = 3
.ColumnWidths = "24;152;152"
.BackColor = &H80000018
.Clear
.List() = Alan()
End With
End Sub
Private Sub ListBox1_Click()
On Error GoTo Hata:
y = ListBox1.ListIndex + 1
If y >= -1 Then
Application.Dialogs(y).Show
End If
Hata:
Select Case Err
Case 18
Exit Sub
Case Else
Resume Next
End Select
End Sub
Sub Excel_Dialog_Pencereleri()
On Error GoTo Hata:
With Application
.EnableCancelKey = xlErrorHandler
For x = 1 To 137
Sheets("Dialoglar").Cells(x + 1, 1) = x
Sheets("Dialoglar").Cells(x + 1, 2) = .Dialogs(x).Application.CommandBars.Item(x).Name
Sheets("Dialoglar").Cells(x + 1, 3) = .Dialogs(x).Application.CommandBars.Item(x).NameLocal
.StatusBar = x
Next
.StatusBar = False
End With
Exit Sub
Hata:
Select Case Err
Case 18
Exit Sub
Case Else
Resume Next
End Select
End Sub

10 Ekim 2007 Çarşamba

Image ComboBox





'UserForm1 

Option Explicit
Dim Liste As New ImageList
Dim Simge As Variant
Dim Kayıt As Variant
Dim i As Long
Dim No
Private Sub UserForm_Initialize() 
     On Error Resume Next 
     Me.Caption = "[PBİD®] Image ComboBox düzenleme...."ImageCombo1.Text = "Seçiniz"
     Simge = Sheets(1).Range("B2:B9").Value
     Kayıt = Sheets(1).Range("C2:C9").Value
     For i = 1 To 8
          Liste.ListImages.Add Key:="img" & i, Picture:=Sheets(1).OLEObjects(Simge(i, 1)).Object.Picture 
     Next
     Set ImageCombo1.ImageList = Liste
     For i = 1 To 7
          ImageCombo1.ComboItems.Add Index:=i, Text:=Kayıt(i, 1), Image:="img" & i, SelImage:="img8" 
     Next
     Set Liste = Nothing
End Sub
Private Sub ImageCombo1_Click() 

     On Error Resume Next
     If Not ImageCombo1.SelectedItem Is Nothing Then
          No = ImageCombo1.SelectedItem.Index
          Select Case No
          Case 1:MsgBox ImageCombo1.SelectedItem.Text
          Case 2:MsgBox ImageCombo1.SelectedItem.Text
          Case 3:MsgBox ImageCombo1.SelectedItem.Text
          Case 4:MsgBox ImageCombo1.SelectedItem.Text
          Case 5:MsgBox ImageCombo1.SelectedItem.Text
          Case 6:MsgBox ImageCombo1.SelectedItem.Text
          Case 7:MsgBox ImageCombo1.SelectedItem.Text
     End Select 
End Sub

1 Ekim 2007 Pazartesi

Add & Delete Images on The Sheet



'Module1

Option Explicit
Dim i As Single
Dim ResimKlasörü As String, ResimAdı As String
Dim Resim As Object, Resimler As Object
Sub SayfayaResimEkle()
On Error Resume Next
ResimKlasörü = "C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\"
For i = 1 To 6
ResimAdı = Cells(i, 3) & "." & Cells(i, 4)
Cells(i, 2).Select
Set Resim = ActiveSheet.Pictures.Insert(ResimKlasörü & ResimAdı)
With Resim

     .ShapeRange.LockAspectRatio = msoFalse
     .ShapeRange.Height = 36
     .ShapeRange.Width = 36
     .ShapeRange.Rotation = 0#
     .ShapeRange.Name = "Logo " & i
End With
Next i
End Sub
Sub SayfadakiResimleriSil()
On Error Resume Next
Set Resimler = ActiveSheet.Shapes
For Each Resim In Resimler
                If VBA.Left(Resim.Name, 4) = "Logo" Then Resim.Delete
Next Resim
End Sub

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