Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2008 Cumartesi

PC Informations




UserForm1

'Add Tools on userForm1: Image1, Label1, ComboBox1, ListBox1
Option Explicit
'Ortak Tanımlamalar

Dim No As Double
Dim Bulgu As String
Dim Yongalar As Object
Dim BilgisayarAdı As String
'ComputerName

Dim SektörAdı As String 'RootName
Dim SınıfAdı As String 'ClassName
Dim İşletimSistemiYongaları As Object 'Windows Management Instrumentation (WMI)
Dim İşletimSistemiYongalarıKartı As Object 'Windows Management Instrumentation (WMIB)
'MotherBoard
Dim AnaKartYongası As Object 'MotherBoard (MB)
'
WMI

Dim Programlar As Variant
Dim YüklüBileşenProgramları
'
BIOS

Dim BIOSBilgisi As Variant
'
Video Controller
Dim EkranKartıBilgisi As Variant
'
Pointing (Mouse) Devices Information

Dim MouseBilgisi As Variant
Dim CPUBilgisi As Variant
'
Network Adapter

Dim AğBilgisi As Variant
S'ys
Dim SistemParçası As Object
'
Operating System (OS)
Dim OS As Object

Private Sub UserForm_Initialize()
On Error Resume Next
Application.Visible = False
Application.VBE.MainWindow.Visible = False
Me.Caption = "[PBİD®] PC Informations"
With TextBox1
.MultiLine = True
.ScrollBars = fmScrollBarsVertical
End With
Call ListeHazırla
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub ComboBox1_Click()
On Error Resume Next
No = ComboBox1.ListIndex
Select Case No
Case Is = 0
Call AnakartBilgileri
Case Is = 1
Call YüklüWindowsBileşenProgramları
Case Is = 2
Call TemelGirişÇıkışSistemiBilgileri
Case Is = 3
Call EkranKartıBilgileri
Case Is = 4
Call FareBilgileri
Case Is = 5
Call AğBağdaştırıcıları
Case Is = 6
Call SistemBilgileri
Case Is = 7
Call İşletimSistemiBilgileri
Case Is = 8
'Call ""
End Select
End Sub
Sub ListeHazırla()
On Error Resume Next
With ComboBox1
.AddItem "Mother Board Information"
.AddItem "Windows Management Instrumentation (WMI)"
.AddItem "Basic Input/Output System (BIOS) Information"
.AddItem "Video Controller Information"
.AddItem "Pointing (Mouse) Devices Information"
.AddItem "Network Adapter Information"
.AddItem "Sys Information"
.AddItem "Operating System (OS) Information"
End With
End Sub
Sub AnakartBilgileri() 'Mother Board Information
On Error Resume Next
BilgisayarAdı = "."
SektörAdı = "Root\CimV2"
SınıfAdı = "Win32_BaseBoard"
Set İşletimSistemiYongaları = GetObject("winmgmts:\\" & BilgisayarAdı & "\" & SektörAdı)
Set İşletimSistemiYongalarıKartı = İşletimSistemiYongaları.ExecQuery("Select * from " & SınıfAdı)
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each AnaKartYongası In İşletimSistemiYongalarıKartı
If VBA.Len(VBA.Trim(AnaKartYongası.Manufacturer)) = 0 Then
Bulgu = "Üretici Firma" & VBA.Chr(9) & "---" & vbCrLf
Else
Bulgu = "Üretici Firma" & VBA.Chr(9) & AnaKartYongası.Manufacturer & vbCrLf
End If
If VBA.Len(VBA.Trim(AnaKartYongası.SerialNumber)) = 0 Then
Bulgu = Bulgu & "Seri Numarası" & VBA.Chr(9) & "---"
Else
Bulgu = Bulgu & "Seri Numarası" & VBA.Chr(9) & AnaKartYongası.SerialNumber
End If
'MsgBox "ANA KART BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & VBA.String(70, "-") & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] MotherBoard (MB)"
TextBox1.Text = Bulgu
TextBox1.SetFocus
Next
End Sub
Sub YüklüWindowsBileşenProgramları() 'Windows Management Instrumentation (WMI)
On Error Resume Next
Bulgu = ""
BilgisayarAdı = "."
Set Yongalar = GetObject("Winmgmts:" & "{ImpersonationLevel=Impersonate}!\\" & BilgisayarAdı & "\Root\CimV2")
Set YüklüBileşenProgramları = Yongalar.ExecQuery("Select * from Win32_Product")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each Programlar In YüklüBileşenProgramları
Bulgu = Bulgu & "Program" & VBA.Chr(9) & Programlar.name & vbCrLf
Bulgu = Bulgu & "Versiyon" & VBA.Chr(9) & Programlar.Version & vbCrLf
Bulgu = Bulgu & "Üretici" & VBA.Chr(9) & Programlar.Vendor & vbCrLf
Bulgu = Bulgu & "Kurulum" & VBA.Chr(9) & VBA.left(Programlar.InstallDate, 4) & "/" & VBA.Mid(Programlar.InstallDate, 5, 2) & "/" & VBA.Mid(Programlar.InstallDate, 7, 2) & vbCrLf
Bulgu = Bulgu & VBA.String(157, "-") & vbCrLf
Next
'MsgBox "MSI İLE YÜKLENMİŞ PROGRAMLAR" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
TextBox1.Text = BulguTextBox1.SetFocus
End Sub
Sub TemelGirişÇıkışSistemiBilgileri() 'Basic Input/Output System (BIOS) Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("Win32_Bios")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each BIOSBilgisi In Yongalar
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & BIOSBilgisi.Manufacturer & vbCrLf
Bulgu = Bulgu & "BIOS Seri Numarası" & VBA.Chr(9) & BIOSBilgisi.SerialNumber & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "BIOS BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Basic Input/Output System (BIOS) Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub EkranKartıBilgileri() 'Video Controller Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("Win32_VideoController")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each EkranKartıBilgisi In Yongalar
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & EkranKartıBilgisi.AdapterCompatibility & "(" & EkranKartıBilgisi.Caption & ")" & vbCrLf
Bulgu = Bulgu & "Yatay Çözünürlük" & VBA.Chr(9) & EkranKartıBilgisi.CurrentHorizontalResolution & vbCrLf
Bulgu = Bulgu & "Dikey Çözünürlük" & VBA.Chr(9) & EkranKartıBilgisi.CurrentVerticalResolution & vbCrLf
Bulgu = Bulgu & "Renk Kalitesi" & VBA.Chr(9) & EkranKartıBilgisi.CurrentBitsPerPixel & " bps" & vbCrLf
Bulgu = Bulgu & "Video Modu" & VBA.Chr(9) & EkranKartıBilgisi.VideoModeDescription & vbCrLf
Bulgu = Bulgu & "İşlemci" & VBA.Chr(9) & VBA.Chr(9) & EkranKartıBilgisi.VideoProcessor & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "EKRAN KARTI BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Video Controller Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub FareBilgileri() 'Pointing (Mouse) Devices Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("win32_PointingDevice")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each MouseBilgisi In Yongalar
Bulgu = Bulgu & "İşlemci" & VBA.Chr(9) & VBA.Chr(9) & Trim(CPUBilgisi.name) & vbCrLf
Bulgu = Bulgu & "Ad" & VBA.Chr(9) & VBA.Chr(9) & MouseBilgisi.name & vbCrLf
Bulgu = Bulgu & "Üretici" & VBA.Chr(9) & VBA.Chr(9) & MouseBilgisi.Manufacturer & vbCrLf
Bulgu = Bulgu & "Buton Adedi" & VBA.Chr(9) & MouseBilgisi.NumberOfButtons & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "MOUSE BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Pointing (Mouse) Devices Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub AğBağdaştırıcıları() 'Network Adapter Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("Win32_NetworkAdapter")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each AğBilgisi In Yongalar
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & AğBilgisi.Manufacturer & vbCrLf
Bulgu = Bulgu & "Adı" & VBA.Chr(9) & VBA.Chr(9) & AğBilgisi.name & vbCrLf
Bulgu = Bulgu & "Tip" & VBA.Chr(9) & VBA.Chr(9) & AğBilgisi.AdapterType & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "AĞ BAĞDAŞTIRICILARI BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Network Adapter Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub SistemBilgileri() 'Sys Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("Winmgmts:").InstancesOf("Win32_ComputerSystem")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each SistemParçası In Yongalar
Bulgu = Bulgu & "Ad" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.name & vbCrLf
Bulgu = Bulgu & "Tip" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.SystemType & vbCrLf
Bulgu = Bulgu & "Üretici" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.Manufacturer & vbCrLf
Bulgu = Bulgu & "Model" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.Model & vbCrLf
Bulgu = Bulgu & "RAM" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.TotalPhysicalMemory \ 1024000 & " Mb" & vbCrLf
Bulgu = Bulgu & "Domain" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.Domain & vbCrLf
Bulgu = Bulgu & "Kayıtlı Kullanıcı" & VBA.Chr(9) & SistemParçası.Username & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "SİSTEM BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Sys Information"
Set Yongalar = Nothing
TextBox1.Text = BulguTextBox1.SetFocus
End Sub
Sub İşletimSistemiBilgileri() 'Operating System (OS) Information
On Error Resume Next
Bulgu = ""
BilgisayarAdı = "."
SektörAdı = "Root\CimV2"
SınıfAdı = "Win32_OperatingSystem"
Set İşletimSistemiYongaları = GetObject("Winmgmts:\\" & BilgisayarAdı & "\" & SektörAdı)
Set İşletimSistemiYongalarıKartı = İşletimSistemiYongaları.ExecQuery("Select * from " & SınıfAdı)
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each OS In İşletimSistemiYongalarıKartı
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & VBA.Chr(9) & OS.Manufacturer & vbCrLf
Bulgu = Bulgu & "Kayitli Kullanici" & VBA.Chr(9) & VBA.Chr(9) & OS.RegisteredUser & vbCrLf
Bulgu = Bulgu & "Windows Seri Numarasi" & VBA.Chr(9) & OS.SerialNumber & vbCrLf
Bulgu = Bulgu & "Windows Versiyonu ID" & VBA.Chr(9) & OS.Version & vbCrLf
Bulgu = Bulgu & "Windows Versiyonu" & VBA.Chr(9) & VBA.Chr(9) & OS.name & vbCrLf
Bulgu = Bulgu & "Güncelleme" & VBA.Chr(9) & VBA.Chr(9) & OS.CSDVersion & vbCrLf
Bulgu = Bulgu & VBA.Mid(VBA.Str(OS.name), 1, VBA.InStr(1, VBA.Str(OS.name), "") - 1) & vbCrLf
Bulgu = Bulgu & "Windows kurulum tarihi" & VBA.Chr(9) & VBA.left(OS.InstallDate, 4) & "/" & VBA.Mid(OS.InstallDate, 5, 2) & "/" & VBA.Mid(OS.InstallDate, 7, 2) & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "İŞLETİM SİSTEMİ BİLGİLERİ" & vbCrLf & VBA.String(130, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Operating System (OS) Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub

10 Aralık 2008 Çarşamba

FileFormat Property

'Module1
'XlFileFormat can be one of these XlFileFormat constants.
'xlCSV
'xlCSVMSDOS
'xlCurrentPlatformText
'xlDBF3
'xlDIF
'xlExcel2FarEast
'xlExcel4
'xlAddIn
'xlCSVMac
'xlCSVWindows
'xlDBF2
'xlDBF4
'xlExcel2
'xlExcel3
'xlExcel4Workbook
'xlExcel5
'xlExcel7
'xlExcel9795
'xlHtml
'xlIntlAddIn
'xlIntlMacro
'xlSYLK
'xlTemplate
'xlTextMac
'xlTextMSDOS
'xlTextPrinter
'xlTextWindows
'xlUnicodeText
'xlWebArchive
'xlWJ2WD1
'xlWJ3
'xlWJ3FJ3
'xlWK1
'xlWK1ALL
'xlWK1FMT
'xlWK3
'xlWK3FM3
'xlWK4
'xlWKS
'xlWorkbookNormal
'xlWorks2FarEast
'xlWQ1
'xlXMLSpreadsheet
Sub MakeFileFormat()
If ActiveWorkbook.FileFormat = xlWK3 Then
ActiveWorkbook.SaveAs fileFormat:=xlNormal
End If
End Sub

1 Aralık 2008 Pazartesi

FileDialog Property




'UserForm1

'Add Tools on UserForm1: Label1, ListBox1, Image1, Label2, CommandButton1
Option Explicit
Dim Sayaç As Long

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] FileDialog Property (Application)..."
Application.Visible = False
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
ListBox1.Clear
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
For Sayaç = 1 To .SelectedItems.Count
ListBox1.AddItem .SelectedItems(Sayaç)
Next Sayaç
End With
End Sub

20 Kasım 2008 Perşembe

MS Windows® Environ Statement



'UserForm1

'Add Tools on UserForm1: Label1...3, ListBox1
Option Explicit
Dim i As Single
Dim No As Double
Dim Dizi As String

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®]Windows® Environ Statement"
Application.Visible = False
With ListBox1
.ColumnCount = 3
.ColumnWidths = "36;120;436"
End With
Call EnvironStatement
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Sub EnvironStatement()
On Error Resume Next
ListBox1.Clear
For i = 1 To 30
Dizi = VBA.Environ(i)
No = Application.WorksheetFunction.Find("=", Dizi, 1)
ListBox1.AddItem i
ListBox1.List((i - 1), 1) = VBA.Mid(Dizi, 1, (No - 1))
ListBox1.List((i - 1), 2) = VBA.Right(Dizi, VBA.Len(Dizi) - No)
Next i
End Sub

10 Kasım 2008 Pazartesi

Link Control




'UserForm1

'Add Tools on UserForm1: Label1, Label2, ListBox1, ListBox2, Image1, label3
Option Explicit
Dim i As Single, ii As Single
Dim Satır As Double, No As Double, Boy0 As Double, Boy1 As Double, Boy2 As Double, Yer As Double
Dim Bağ As Variant
Dim Hücre As Range
Dim HücreMetin As String, BağMetin As String, DosyaMetin As String, Taranan As String

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Link Control..."
BağlantıAraştır
End Sub
Private Sub ListBox1_Click()
On Error GoTo Hata:
No = 0
With ListBox2
.Clear
.ColumnCount = 2
.ColumnWidths = "72;24"
End With
Satır = ListBox1.ListIndex
BağMetin = ListBox1.List(Satır, 0)
Boy1 = VBA.Len(BağMetin)
For ii = 1 To Boy1
If VBA.Left(VBA.Right(BağMetin, ii), 1) = "\" Then
DosyaMetin = VBA.Right(BağMetin, (ii - 1))
Boy0 = VBA.Len(DosyaMetin)
Exit For
End If
Next ii
i = 0
For i = 1 To ThisWorkbook.Worksheets.Count
For Each Hücre In Sheets(i).UsedRange
HücreMetin = Hücre.Formula
If (HücreMetin <> "") Then
Boy2 = VBA.Len(HücreMetin)
For ii = 1 To Boy2
Taranan = VBA.Left(VBA.Right(HücreMetin, ii + Boy0), Boy0)
If Taranan = DosyaMetin Then
ListBox2.AddItem Sheets(i).Name
ListBox2.List(No, 1) = Hücre.Address
No = No + 1
Exit For
End If
Next ii
End If
Next Hücre
Next i
Exit Sub
Hata:
ListBox2.Clear
End Sub
Sub BağlantıAraştır()
On Error GoTo Hata:
Bağ = ActiveWorkbook.LinkSources(xlOLELinks)
If Not IsEmpty(Bağ) Then
For i = 1 To UBound(Bağ)
BağMetin = Bağ(i)
ListBox1.AddItem Bağ(i)
Next i
End If
Bağ = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(Bağ) Then
For i = 1 To UBound(Bağ)
BağMetin = Bağ(i)
ListBox1.AddItem BağMetin
Next i
End If
Hata:
End Sub

1 Kasım 2008 Cumartesi

Color_Number



'Module1

Option Explicit
Dim i As Integer
Dim Alan As Range, Eleman As Range

Sub Renk_No()
On Error Resume Next
Set Alan = Sheets("Sayfa1").UsedRange
For i = 1 To 56
For Each Eleman In Alan
If Eleman.Value = i Then
Eleman.Offset(0, 1).Interior.ColorIndex = i
End If
Next Eleman
Next i
End Sub

20 Ekim 2008 Pazartesi

Twelve-Level Progress Account



'UserForm1

'Add Tools on UserForm1: ProgressBar1....12, Label1....16, CommandButton1, Image1, Label17
Option Explicit
Dim i As Long
Dim ii As Long
Dim iii As Long
Dim iv As Long
Dim v As Long
Dim vi As Long
Dim vii As Long
Dim viii As Long
Dim ix As Long
Dim x As Long
Dim xi As Long
Dim xii As Long

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] Twelve-Level Progress Account..."
ProgressBar1.Max = 12: ProgressBar1.Min = 1
ProgressBar2.Max = 11: ProgressBar2.Min = 1
ProgressBar3.Max = 10: ProgressBar3.Min = 1
ProgressBar4.Max = 9: ProgressBar4.Min = 1
ProgressBar5.Max = 8: ProgressBar5.Min = 1
ProgressBar6.Max = 7: ProgressBar6.Min = 1
ProgressBar7.Max = 6: ProgressBar7.Min = 1
ProgressBar8.Max = 5: ProgressBar8.Min = 1
ProgressBar9.Max = 4: ProgressBar9.Min = 1
ProgressBar10.Max = 3: ProgressBar10.Min = 1
ProgressBar11.Max = 2: ProgressBar11.Min = 1
ProgressBar12.Max = 1: ProgressBar12.Min = 1
Hata:
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Label13.Caption = VBA.Format(Now, "hh:mm:ss")
For i = 1 To 12
ProgressBar1.Value = i: Label1.Caption = "%" & VBA.Round((i / 12) * 100, 2): DoEvents
For ii = 1 To 11
ProgressBar2.Value = ii: Label2.Caption = "%" & VBA.Round((ii / 11) * 100, 2): DoEvents
For iii = 1 To 10
ProgressBar3.Value = iii: Label3.Caption = "%" & VBA.Round((iii / 10) * 100, 2): DoEvents
For iv = 1 To 9
ProgressBar4.Value = iv: Label4.Caption = "%" & VBA.Round((iv / 9) * 100, 2): DoEvents
For v = 1 To 8
ProgressBar5.Value = v: Label5.Caption = "%" & VBA.Round((v / 8) * 100, 2): DoEvents
For vi = 1 To 7
ProgressBar6.Value = vi: Label6.Caption = "%" & VBA.Round((vi / 7) * 100, 2): DoEvents
For vii = 1 To 6
ProgressBar7.Value = vii: Label7.Caption = "%" & VBA.Round((vii / 6) * 100, 2): DoEvents
For viii = 1 To 5
ProgressBar8.Value = viii: Label8.Caption = "%" & VBA.Round((viii / 5) * 100, 2): DoEvents
For ix = 1 To 4
ProgressBar9.Value = ix: Label9.Caption = "%" & VBA.Round((ix / 4) * 100, 2): DoEvents
For x = 1 To 3
ProgressBar10.Value = x: Label10.Caption = "%" & VBA.Round((x / 3) * 100, 2): DoEvents
For xi = 1 To 2
ProgressBar11.Value = xi: Label11.Caption = "%" & VBA.Round((xi / 2) * 100, 2): DoEvents
For xii = 1 To 1
ProgressBar12.Value = xii: Label12.Caption = "%" & VBA.Round((xii / 1) * 100, 2): DoEvents
Next xii
Next xi
Next x
Next ix
Next viii
Next vii
Next vi
Next v
Next iv
Next iii
Next ii
Next i
Label14.Caption = VBA.Format(Now, "hh:mm:ss")
Hata:
End Sub

10 Ekim 2008 Cuma

To Consolidate Duplicate Records




'UserForm1

'Add Tools On UserForm1: ListBox1, CommandButton1, Label, Image1, Label2
Option Explicit
Dim Seçim As Variant
Dim i As Long, No As Long
Dim Bulunan As Range
Dim Hesaplanan As Double

Private Sub UserForm_Initialize()
On Error GoTo Hata
Me.Caption = "[PBİD®] To Consolidate Duplicate Records..."
Call BilgiGetir
Hata:
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
End Sub
Private Sub CommandButton1_Click()
On Error GoTo Hata
Durak1:
No = Cells(65536, 2).End(xlUp).Row
For i = 1 To No
Seçim = Cells(i, 2).Value
Hesaplanan = 0
Hesaplanan = Hesaplanan + Cells(i, 3).Value
If ((i + 1) > No) Then Exit For
For Each Bulunan In Range(Cells((i + 1), 2), Cells(No, 2))
If Seçim = Bulunan Then
Hesaplanan = Hesaplanan + VBA.Val(Bulunan.Offset(0, 1))
Bulunan.EntireRow.Delete
Application.Cells(i, 3).Value = Hesaplanan
GoTo Durak1
End If
Next Bulunan
Next i
Call BilgiGetir
Exit Sub
Hata:
End Sub
Sub BilgiGetir()
On Error GoTo Hata
Hesaplanan = 0
No = Cells(65536, 2).End(xlUp).Row
ReDim Hafıza(1 To No, 1 To 3)
For i = 1 To No
Hafıza(i, 1) = Cells(i, 1)
Hafıza(i, 2) = Cells(i, 1).Offset(0, 1)
Hafıza(i, 3) = Cells(i, 1).Offset(0, 2)
Hesaplanan = Hesaplanan + VBA.Val(Hafıza(i, 3))
Next
With ListBox1
.ColumnCount = 3
.ColumnWidths = "24;150;36"
.List() = Hafıza()
End With
Label1.Caption = Hesaplanan
End Sub

1 Ekim 2008 Çarşamba

Workbook Menu




'ThisWorkbook

Option Explicit
Private Sub Workbook_Open()
     On Error Resume Next
     Call Menü_Kur
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     On Error Resume Next
     Call Menü_Yoket

End Sub

'Module1

Option Explicit
Public Const Sistem_Menü = "Worksheet Menu Bar"
Public Const Program_Menüsü = "PBİD®"
Dim Eleman$
Dim Alt_Eleman$
Sub Menü_Kur()
     On Error Resume Next
     Program_Menüsü_Temizle
Program_Menüsü
     Application.CommandBars.Add Program_Menüsü, , True 'CommandBar / ToolBarMenüsü

     Eleman = "&Bir"
     CommandBars(Program_Menüsü).Controls.Add(Type:=msoControlPopup).Caption = Eleman
     With CommandBars(Program_Menüsü).Controls(Eleman)

          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .FaceId = 3
               .State = msoButtonUp
               .Enabled = True
               .BeginGroup = False

          End With
          Eleman = "Menü&2"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .State = msoButtonDown
               .Enabled = False
               .BeginGroup = True
               .FaceId = 4

          End With
          Eleman = "Menü&3"
          .Controls.Add(Type:=msoControlEdit).Caption = Eleman
          With .Controls(Eleman)

               .Tag = "TestEditBox"
               .Text = "Yazılı Komutunuz"
               .OnAction = "Komut"

          End With
          Alt_Eleman = "Menü&4"
          .Controls.Add(Type:=msoControlPopup).Caption = Alt_Eleman
          With .Controls(Alt_Eleman)

               Eleman = "Alt Menü&1"
               .Controls.Add(Type:=msoControlButton).Caption = Eleman
               With .Controls(Eleman)

                    .OnAction = "Komut"
               End With
               Eleman = "Alt Menü&2"
               .Controls.Add(Type:=msoControlButton).Caption = Eleman
               With .Controls(Eleman)

                    .OnAction = "Komut"
               End With
               Eleman = "Alt Menü&3"

               .Controls.Add(Type:=msoControlButton).Caption = Eleman
               With .Controls(Eleman)
                    .OnAction = "Komut"
               End With
          End With
          Eleman = "Menü&5"
          .Controls.Add(Type:=msoControlComboBox).Caption = Eleman
          With .Controls(Eleman)

               '.Delete
               .OnAction = "Komut1"
               .Visible = True
               .Enabled = True
               .AddItem "Bir"
               .AddItem "İki"
               .AddItem "Üç"
               .AddItem "Dört"
               .AddItem "Beş"
               .AddItem "Altı"
               .ListIndex = 4
               .DropDownWidth = 36

          End With
          Eleman = "Menü&6"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .State = msoButtonDown
               .BeginGroup = True

          End With
     End With
     Eleman = "&İki"
     CommandBars(Program_Menüsü).Controls.Add(msoControlPopup).Caption = Eleman
     With CommandBars(Program_Menüsü).Controls(Eleman)

          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          .Controls(Eleman).OnAction = "Komut"
          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .BeginGroup = True

          End With
          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
          End With
          Eleman = "Menü&1"
          .Controls.Add(Type:=msoControlButton).Caption = Eleman
          With .Controls(Eleman)

               .OnAction = "Komut"
               .BeginGroup = True

          End With
     End With
     CommandBars(Program_Menüsü).Visible = True

End Sub

'Module2

Option Explicit
Dim Menü_Bar_Elemanı

Sub Kullanılan_Menü()
     On Error Resume Next
     MsgBox CommandBars.ActiveMenuBar.Name

End Sub
Sub Sistem_Menüsü_Düzenle()
     On Error Resume Next
     CommandBars(Sistem_Menü).Visible = True

End Sub
Sub Program_Menüsü_Düzenle()
     On Error Resume Next
     CommandBars(Program_Menüsü).Visible = True

End Sub
Sub Menü_Yoket()
     On Error Resume Next
     Program_Menüsü_Temizle Program_Menüsü

End Sub
Sub Program_Menüsü_Temizle(Menü_Adı)
     On Error Resume Next
     For Each Menü_Bar_Elemanı In CommandBars

          If Menü_Bar_Elemanı.Name = Menü_Adı Then
                Menü_Bar_Elemanı.Delete
          End If
     Next
End Sub
Sub Komut()
     On Error Resume Next
     MsgBox CommandBars.FindControl(Tag:="TestEditBox").Text

End Sub
Sub Komut1()
     On Error Resume Next
     Dim Seçim
     Seçim = CommandBars(Program_Menüsü).Controls("Bir").Controls("Menü5").ListIndex
     Select Case Seçim

          Case 1 :MsgBox "1"
          Case 2 :MsgBox "2"
          Case 3 :MsgBox "3"
          Case 4 :MsgBox "4"
          Case 5 :MsgBox "5"
          Case 6 :MsgBox "6"
     End Select
End Sub

20 Eylül 2008 Cumartesi

Page Setup

'Module1
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Sheets("Sheet2").PageSetup.PrintArea = Range("A1:F" & Cells(65536, 1).End(xlUp).Row).Address
End Sub

10 Eylül 2008 Çarşamba

Page Select

'UserForm1

'Add Tools On UserForm1: MultiPage1, CommandButton1

Private Sub CommandButton1_Click()
MultiPage1.Pages(1).Visible = True
MultiPage1.Value = 1 '0= First Page
End Sub

1 Eylül 2008 Pazartesi

Delete File and Folder By Microsoft Scripting Runtime


'Module1

'Referance: Microsoft Scripting Runtime= c:\Windows\System32\Scrrun.dll
Option Explicit
Dim Klasör, KökKlasör As String
Dim FSO As New Scripting.FileSystemObject
Dim ScrKlasör, ScrKlasör1 As Scripting.Folder
Dim ScrDosya As Scripting.File

Sub DosyaKlasörSil_1()
On Error Resume Next
Klasör = InputBox("İçeriğini temizlemek istediğiniz klasör yolunu yazınız..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com" & vbCrLf & vbCrLf & "Örnek: c:\Deneme", "[PBİD®] Klasör Temizliği", "C:\Deneme")
Set ScrKlasör = FSO.GetFolder(Klasör)
If FSO.FolderExists(ScrKlasör) = False Then
MsgBox "Geçerli Klasör Yolu Tanımladığınızdan Emin Olun." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat!!!"
End
End If
On Error GoTo 0
For Each ScrDosya In ScrKlasör.Files
ScrDosya.Delete
Next
KökKlasör = MsgBox("Alt Klasörleri de silmek istiyor musunuz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbQuestion + vbYesNo, "[PBİD®]Lütfen Dikkat")
If KökKlasör = vbNo Then Exit Sub
For Each ScrKlasör1 In ScrKlasör.SubFolders
ScrKlasör1.Delete
Next
ScrKlasör.Delete
End Sub
Sub DosyaKlasörSil_2()
On Error Resume Next
Klasör = InputBox("İçeriğini temizlemek istediğiniz klasör yolunu yazınız..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com" & vbCrLf & vbCrLf & "Örnek: c:\Deneme", "[PBİD®] Klasör Temizliği", "C:\Deneme")
Set ScrKlasör = FSO.GetFolder(Klasör)
If FSO.FolderExists(ScrKlasör) = False Then
MsgBox "Geçerli Klasör Yolu Tanımladığınızdan Emin Olun." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat!!!"
End
End If
On Error GoTo 0
For Each ScrDosya In ScrKlasör.Files
ScrDosya.Delete
Next
KökKlasör = MsgBox("Alt Klasörleri de silmek istiyor musunuz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbQuestion + vbYesNo, "[PBİD®]Lütfen Dikkat")
If KökKlasör = vbNo Then Exit Sub
For Each ScrKlasör1 In ScrKlasör.SubFolders
ScrKlasör1.Delete
Next
ScrKlasör.Delete
End Sub

20 Ağustos 2008 Çarşamba

Delete Rows




'Sheets("Sayfa1") Module

Option Explicit
Dim SonSatır As Variant
Dim r As Single

Private Sub CommandButton1_Click()
On Error Resume Next
Call BoşSatırlarıSil
End Sub
Sub BoşSatırlarıSil()
On Error GoTo Hata:
SonSatır = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = SonSatır To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
Hata:
End Sub

10 Ağustos 2008 Pazar

UserForm QueryClose




'UserForm1

'Add Tools on UserForm1: Label1, label2, Label3, ComboBox1, ComboBox2, Label4
Option Explicit
Dim Vazgeçme As Boolean
Dim Yöntemi As Long

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] UserForm QueryClose..."
With ComboBox1
'Cancel

.AddItem "False"
.AddItem "True"
.ListIndex = 0
End With
With ComboBox2
'CloseMode

.AddItem "0"
.AddItem "1"
.ListIndex = 0
End With
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
UnLoad Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
CloseMode = Yöntemi
If CloseMode = 0 Then
Cancel = Vazgeçme
Else
Cancel = True
End If
End Sub
Private Sub ComboBox1_Change() 'Cancel
On Error Resume Next
Vazgeçme = ComboBox1.Value
If Vazgeçme = False And Yöntemi = 0 Then
CommandButton1.Enabled = True
Else
CommandButton1.Enabled = False
End If
End Sub
Private Sub ComboBox2_Change() 'CloseMode
On Error Resume Next
Yöntemi = ComboBox2.Value
If Vazgeçme = False And Yöntemi = 0 Then
CommandButton1.Enabled = True
Else
CommandButton1.Enabled = False
End If
End Sub

1 Ağustos 2008 Cuma

Create New vbComponents (Sheet, Chart, DialogSheet)




'UserForm1

'Add Tools on UserForm1: ComboBox1, Label1, TextBox1, ListBox1, CommandButton1, Label2, Label3
Option Explicit
Dim i As Integer
Dim Tip, Eleman, YeniEleman

Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] CREATE New vbComponents on UserForm..."
With ComboBox1
.AddItem 1: .List(0, 1) = "xlWorksheet"
.AddItem 2: .List(1, 1) = "xlChart"
.AddItem 3: .List(2, 1) = "xlExcel4MacroSheet"
.AddItem 4: .List(3, 1) = "xlExcel4IntlMacroSheet"
.AddItem 5: .List(4, 1) = "xlDialogSheet"
.ColumnCount = 2
.ColumnWidths = "18;54"
.ListWidth = (18 + 54)
End With
Call ListeDüzenle
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
Label1.Caption = " " & ComboBox1.List(ComboBox1.ListIndex, 1)
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Tip = ComboBox1.Value
YeniEleman = TextBox1.Value
If Tip <> "" And YeniEleman <> "" Then
Sheets.Add , Sheets(Worksheets.Count), , VBA.Val(Tip)
Call ListeDüzenle
End If
End Sub
Sub ListeDüzenle()
On Error Resume Next
ListBox1.Clear
For Each Eleman In Application.VBE.ActiveVBProject.vbComponents
ListBox1.AddItem Eleman.Name
Next Eleman
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