Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ağustos 2005 Cumartesi

Week Number Of Day Serial




'UserForm1

'AddTools on UserForm1: Image1, Label1, Label2, Label3, Label4, Label5, ListBox1, CommandButton1, TextBox1, Label6, TextBox2, Label7, Label8
Option Explicit
Dim i As Single
Dim Adet As Double
Dim Tarih As Date
Dim a, b, c, d, e, f, g, h

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®]Week Number Of Day Serial"
.width = 281
.height = 289
.BackColor = &H80000016
End With
With ListBox1
.ColumnCount = 4
.ColumnWidths = "42;42;42;126"
.Font.Size = 8
End With
Application.Visible = True
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
TextBox1.Value = VBA.Format("1/9/2008", "dd.mm.yyyy")
TextBox2.Value = VBA.Format(VBA.DateValue("1/1/2009") + 90, "dd.mm.yyyy")
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() '[Week Number]
On Error Resume Next
ListBox1.Clear
If VBA.IsDate(VBA.DateValue(TextBox1.Value)) = True And VBA.IsDate(VBA.DateValue(TextBox2.Value)) = True Then
Adet = VBA.DateValue(TextBox2.Value) - VBA.DateValue(TextBox1.Value) + 1
For i = 1 To Adet
Tarih = (i - 1) + VBA.DateValue(TextBox1.Value)
With ListBox1
.AddItem
.List((i - 1), 3) = VBA.Format(Tarih, "dd.mmmm.yyyy dddd")
a = Tarih
'Dönem Sonu tarih
b = VBA.Weekday(Tarih, 2) 'Dönem Sonunun Hafta İçi Gün No
c = VBA.DateSerial(VBA.Year(Tarih) - 1, 12, 31)
'Dönem Sonu Tarihten Önceki Yılın Son Günü
d = VBA.Weekday(c, 2) 'Dönem Başının Hafta İçi Gün No
e = (a + (7 - b))
'Dönem Sonu Haftasının Son Günü
f = (c + (7 - d))
'Dönem Başı Haftasının Son Günü
g = e - f
'İki Hafta Sonu tarih Arasında Geçen Tam Haftalara Ait Gün Sayısı
h = g / 7 'İki Hafta Sonu Tarih Arasında Geçen Hafta Sayısı
If h = 0 Then h = 52
.List((i - 1), 1) = h
.List((i - 1), 2) = b
a = (i - 1) + VBA.DateValue(TextBox1.Value)
'Dönem Sonu tarih
b = VBA.Weekday(Tarih, 2) 'Dönem Sonunun Hafta İçi Gün No
c = VBA.DateValue(TextBox1.Value)
'Dönem Başı Tarih
d = VBA.Weekday(c, 2) 'Dönem Başının Hafta İçi Gün No
e = (a + (7 - b))
'Dönem Sonu Haftasının Son Günü
f = (c + (7 - d))
'Dönem Başı Haftasının Son Günü
g = e - f 'İki Hafta Sonu tarih Arasında Geçen Tam Haftalara Ait Gün Sayısı
h = g / 7 'İki Hafta Sonu Tarih Arasında Geçen Hafta Sayısı
.List((i - 1), 0) = h + 1
DoEvents
End With
Next i
Label1.Caption = ListBox1.List(0, 1)
Label2.Caption = ListBox1.List((Adet - 1), 1)
a = VBA.DateValue(TextBox2.Value) 'Dönem Sonu tarih
b = VBA.Weekday(Tarih, 2)
'Dönem Sonunun Hafta İçi Gün No
c = VBA.DateValue(TextBox1.Value) 'Dönem Başı Tarih
d = VBA.Weekday(c, 2) 'Dönem Başının Hafta İçi Gün No
e = (a + (7 - b)) 'Dönem Sonu Haftasının Son Günü
f = (c + (7 - d)) 'Dönem Başı Haftasının Son Günü
g = e - f 'İki Hafta Sonu tarih Arasında Geçen Tam Haftalara Ait Gün Sayısı
h = g / 7
'İki Hafta Sonu Tarih Arasında Geçen Hafta Sayısı
Label3.Caption = h + 1
End If
End Sub

10 Ağustos 2005 Çarşamba

Ongoing Search



'Module1

Option Explicit
Dim i As Single, No As Double
Dim Hücre As Range, Sayfa As Worksheet
Dim Adres As String, Aranan As String, Bulunan As String, ÖncekiBulunan As String, Bilgi As String

Sub DevamEdenArama() '[Ongoing search]
On Error Resume Next
Set Sayfa = ThisWorkbook.Sheets(1)
No = Sayfa.Range("A65536").End(xlUp).Row
i = 1
Aranan = Sayfa.Range("E2").Value
Bulunan = ""
ÖncekiBulunan = ""
Bilgi = ""
Durak1:
Set Hücre = Nothing
Adres = "A" & i & ":A" & No
Set Hücre = Range(Adres).Find(Aranan, , , , , xlNext)
Bulunan = Hücre.Address
If Bulunan = ÖncekiBulunan Then
GoTo Durak2
Else
If i = 1 Then
Bilgi = Bulunan
i = Hücre.Row
Range(Bilgi).Select
Else
Bilgi = Bilgi & "," & Bulunan
i = Hücre.Row
Range(Bilgi).Select
End If
ÖncekiBulunan = Bulunan
End If
GoTo Durak1
Durak2:
MsgBox "Bulunan Kayıtlar:" & Bilgi & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Devam Eden Arama..."
End Sub

1 Ağustos 2005 Pazartesi

Resizable DialogSheet And DialogFrame



'Module1

Option Explicit
Public Resimlik As New Image
Public ÖrnekDS As DialogSheet
Dim Ekran As New Class1

Sub DialogSheet_Open()
On Error Resume Next
Set Resimlik.Picture = LoadPicture("C:\Program Files\Microsoft Office\OFFICE11\MSN.ico")
Application.DisplayAlerts = False
DialogSheets.Add
Set ÖrnekDS = ThisWorkbook.ActiveSheet
With ÖrnekDS
.Name = "ÖrnekDS1"
With .DialogFrame
.Name = "Çerçeve1"
.OnAction = "DialogSheet_Show"
.Caption = "[PBİD®] Resizable DialogSheet..."
End With
.Show
.Delete
End With
Application.DisplayAlerts = True
End Sub
Sub DialogSheet_Show()
On Error Resume Next
Set Ekran.SimgeEkle2 = ÖrnekDS
Set Ekran.Ekran2 = ÖrnekDS
End Sub

'Class1

Option Explicit
'Simge

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Ekran

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
'Simge ve Ekran

Private Pencere As Long, Tercih As Long, FIcon As Long, Tarz As Long, Sonuç As Long
Public Property Set SimgeEkle1(ByVal Ekran As Object) 'UserForm için
On Error Resume Next
FIcon = Ekran.Image1.Picture.Handle
Pencere = FindWindow(vbNullString, Ekran.Caption)
Tercih = SendMessage(Pencere, &H80, 0&, ByVal FIcon)
Tercih = SendMessage(Pencere, &H80, 1&, ByVal FIcon)
Tercih = DrawMenuBar(Pencere)
Tarz = GetWindowLong(Pencere, (-20))
Tarz = Tarz Or &H40000
Sonuç = SetWindowPos(Pencere, 0, 0, 0, 0, 0, &H2 Or &H1 Or &H10 Or &H80)
Sonuç = SetWindowLong(Pencere, (-20), Tarz)
Sonuç = SetWindowPos(Pencere, 0, 0, 0, 0, 0, &H2 Or &H1 Or &H10 Or &H40)
End Property
Public Property Set SimgeEkle2(ByVal Ekran As Object) 'DialogSheet için
On Error Resume Next
FIcon = Resimlik.Picture.Handle
Pencere = FindWindow(vbNullString, Ekran.DialogFrame.Caption)
Tercih = SendMessage(Pencere, &H80, 0&, ByVal FIcon)
Tercih = SendMessage(Pencere, &H80, 1&, ByVal FIcon)
Tercih = DrawMenuBar(Pencere)
Tarz = GetWindowLong(Pencere, (-20))
Tarz = Tarz Or &H40000
Sonuç = SetWindowPos(Pencere, 0, 0, 0, 0, 0, &H2 Or &H1 Or &H10 Or &H80)
Sonuç = SetWindowLong(Pencere, (-20), Tarz)
Sonuç = SetWindowPos(Pencere, 0, 0, 0, 0, 0, &H2 Or &H1 Or &H10 Or &H40)
End Property
Public Property Set Ekran1(ByVal Ekran As Object) 'UserForm için
On Error Resume Next
Pencere = FindWindow(vbNullString, Ekran.Caption)
Tarz = GetWindowLong(Pencere, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong Pencere, (-16), Tarz
ShowWindow Pencere, 3
DrawMenuBar Pencere
End Property
Public Property Set Ekran2(ByVal Ekran As Object) 'DialogSheet için
On Error Resume Next
Pencere = FindWindow(vbNullString, Ekran.DialogFrame.Caption)
Tarz = GetWindowLong(Pencere, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong Pencere, (-16), Tarz
ShowWindow Pencere, 5
DrawMenuBar Pencere
End Property

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