Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Mart 2007 Salı

Date Statement Weekly Planning



'UserForm1

'A) VBProject References List [Excel 2003]

'Visual Basic For Application= [C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL]
'Microsoft Excel 11.0 Object Library= [c:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE]
'OLE Automation= [C:\WINDOWS\system32\stdole2.tlb]
'Microsoft Office 11.0 Object Library= [C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL]
'Microsoft Forms 2.0 Object Library= [C:\WINDOWS\system32\FM20.DLL]
'Microsoft Windows Common Control 6.0 (SP6)= [C:\WINDOWS\system32\MSCOMCTL.OCX]
'B) Addition Tools on UserForm1
'Frame1
'Frame2
'Frame2\Label1, Image1
'Frame3
'Frame3\Label2, Label3, TextBox1, TextBox2, CommandButton1
'TreeView1
Option Explicit
Dim Durum As Boolean
Dim i As Single
Dim GünAdet As Double, HaftaAdet As Double, AyAdet As Double, YılAdet As Double, HaftaGünü As Double
Dim DB As Date, DS As Date
Dim AğaçHafıza, DalAnahtar As String, KökAnahtar As String, DalAdı As String
Dim Resimlik As New ImageList
Dim KYıl(1 To 1000) As MSForms.Label
Dim KAy(1 To 12000) As MSForms.Label
Dim KHafta(1 To 52000) As MSForms.Label
Dim KGün(1 To 365000) As MSForms.Label
Dim KGünBar(1 To 365000) As MSForms.Label
Dim Eleman As Control
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Date Statement Weekly Planning"
Durum = True
Call EkranHazırla
Application.Visible = False
Application.VBE.MainWindow.Visible = False
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
TextBox1.Text = VBA.Format(VBA.Now, "dd.mm.yyyy")
TextBox2.Text = VBA.Format(VBA.Now + 720, "dd.mm.yyyy")
Call Hesapla
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer
)

On Error Resume Next
Application.Visible = True
Application.VBE.MainWindow.Visible = True
Durum = False
End Sub
Private Sub CommandButton1_Click()

On Error GoTo Hata
Call Hesapla
Hata:
End Sub
Private Sub TreeView1_Click()

On Error Resume Next
DalAdı = TreeView1.SelectedItem.Text
Frame1.ScrollLeft = (VBA.CDate(VBA.Left(DalAdı, 11)) - VBA.CDate(DB)) * 18
End Sub
Private Sub TreeView1_KeyUp(KeyCode As Integer, ByVal Shift As Integer)

On Error Resume Next
DalAdı = TreeView1.SelectedItem.Text
Frame1.ScrollLeft = (VBA.CDate(VBA.Left(DalAdı, 11)) - VBA.CDate(DB)) * 18
End Sub
Sub Hesapla()

On Error GoTo Hata
TreeView1.Nodes.Clear
DB = VBA.CDate(TextBox1.Value): TextBox1.Text = DB
DS = VBA.CDate(TextBox2.Value): TextBox2.Text = DS
GünAdet = VBA.DateDiff("d", DB, DS, vbSunday, vbUseSystem) + 1
HaftaAdet = VBA.DateDiff("w", DB, DS, vbSunday, vbUseSystem) + 1
AyAdet = VBA.DateDiff("m", DB, DS, vbSunday, vbUseSystem) + 1
YılAdet = VBA.DateDiff("yyyy", DB, DS, vbSunday, vbUseSystem) + 1
Label3.Caption = GünAdet
Frame1.ScrollWidth = GünAdet * 18
Call TarihHazırla(GünAdet)
Call AğaçHazırla(GünAdet)
Call GantHazırla(YılAdet, AyAdet, HaftaAdet, GünAdet)
Exit Sub
Hata:
TreeView1.Nodes.Clear
End Sub
Private Function TarihHazırla(GünAdet)

On Error GoTo Hata
ReDim Hafıza(1 To GünAdet, 1 To 3)
For i = 1 To GünAdet
Hafıza(i, 1) = VBA.Format(VBA.DateAdd("d", (i - 1), DB), "dd.mmm.yyyy w dddd")
Hafıza(i, 2) = VBA.Format(VBA.DateAdd("d", (i - 1), DB), "yyyy")
If VBA.Format(VBA.DateAdd("d", (i - 1), DB), "ww") = 53 Then
Hafıza(i, 3) = VBA.Format(VBA.DateAdd("d", (i - 1), DB), "ww")
Else
Hafıza(i, 3) = VBA.Format(VBA.DateAdd("d", (i - 1), DB), "ww")
End If
Next i
AğaçHafıza = Hafıza()
Hata:
Erase Hafıza
End Function
Private Function AğaçHazırla(GünAdet)

On Error GoTo Hata
TreeView1.ImageList = Resimlik
For i = 1 To GünAdet
If i = 1 Then
DalAdı = AğaçHafıza(i, 2)
DalAnahtar = "Key" & AğaçHafıza(i, 2)
TreeView1.Nodes.Add , 1, DalAnahtar, DalAdı, "Resim1"
DalAdı = AğaçHafıza(i, 3)
DalAnahtar = "Key" & AğaçHafıza(i, 2) & "_" & AğaçHafıza(i, 3)
KökAnahtar = "Key" & AğaçHafıza(i, 2)
TreeView1.Nodes.Add KökAnahtar, 4, DalAnahtar, DalAdı, "Resim1"
Else
If (AğaçHafıza(i, 2) <> AğaçHafıza((i - 1), 2)) Then
DalAdı = AğaçHafıza(i, 2)
DalAnahtar = "Key" & AğaçHafıza(i, 2)
TreeView1.Nodes.Add , 1, DalAnahtar, DalAdı, "Resim1"
End If
If (AğaçHafıza(i, 3) <> AğaçHafıza((i - 1), 3)) Or (AğaçHafıza(i, 3) = AğaçHafıza((i - 1), 3)) And (AğaçHafıza(i, 2) <> AğaçHafıza((i - 1), 2)) Then
DalAdı = AğaçHafıza(i, 3)
DalAnahtar = "Key" & AğaçHafıza(i, 2) & "_" & AğaçHafıza(i, 3)
KökAnahtar = "Key" & AğaçHafıza(i, 2)
TreeView1.Nodes.Add KökAnahtar, 4, DalAnahtar, DalAdı, "Resim1"
End If
End If
DalAdı = AğaçHafıza(i, 1)
DalAnahtar = "Key" & AğaçHafıza(i, 1)
KökAnahtar = "Key" & AğaçHafıza(i, 2) & "_" & AğaçHafıza(i, 3)
TreeView1.Nodes.Add KökAnahtar, 4, DalAnahtar, DalAdı, "Resim1"
Next i
For i = 1 To TreeView1.Nodes.Count
If (TreeView1.Nodes(i).Children > 0) Then
TreeView1.Nodes(i).ForeColor = vbBlack
TreeView1.Nodes(i).Bold = True
TreeView1.Nodes(i).Expanded = True
Else
HaftaGünü = VBA.Right(VBA.Left(TreeView1.Nodes(i).Text, 13), 1)
If HaftaGünü = 1 Or HaftaGünü = 7 Then
TreeView1.Nodes(i).ForeColor = &H80000003
Else
TreeView1.Nodes(i).ForeColor = vbBlue
End If
TreeView1.Nodes(i).Bold = False
End If
Next i
TreeView1.Nodes(1).Selected = True
Hata:
Erase AğaçHafıza
End Function
Function GantHazırla(YılAdet, AyAdet, HaftaAdet, GünAdet)

On Error Resume Next
For Each Eleman In Frame1.Controls
Set Eleman = Nothing
Next Eleman
For i = 1 To YılAdet
Set KYıl(i) = Me.Frame1.Controls.Add("Forms.Label.1")
With KYıl(i)
.Caption = VBA.Year(DB) + (i - 1)
.BackStyle = fmBackStyleOpaque
.BorderColor = &H80000016
.Top = 0
If i = 1 Then
.Left = 0
Else
.Left = KYıl(i - 1).Left + KYıl(i - 1).Width
End If
.Width = (VBA.DateSerial(VBA.Year(DB) + (i - 1), 12, 31) - VBA.DateSerial(VBA.Year(DB) + (i - 1), 1, 1) + 1) * 18
.Height = 12
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
End With
Next i
For i = 1 To AyAdet
Set KAy(i) = Me.Frame1.Controls.Add("Forms.Label.1")
With KAy(i)
.Caption = VBA.Format(VBA.DateSerial(VBA.Year(DB), VBA.Month(DB) + (i - 1), 1), "mmmm")
.BackStyle = fmBackStyleOpaque
.BorderColor = &H80000016
.Top = 12
If i = 1 Then
.Left = 0
Else
.Left = KAy(i - 1).Left + KAy(i - 1).Width
End If
.Width = (VBA.DateSerial(VBA.Year(DB), VBA.Month(DB) + i, 1) - VBA.DateSerial(VBA.Year(DB), VBA.Month(DB) + (i - 1), 1)) * 18
.Height = 12
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
End With
Next i
For i = 1 To HaftaAdet
Set KHafta(i) = Me.Frame1.Controls.Add("Forms.Label.1")
With KHafta(i)
.Caption = "Hafta No: " & VBA.Format(VBA.DateAdd("d", (i - 1) * 7, DB), "ww")
.BackStyle = fmBackStyleOpaque
.BorderColor = &H80000016
.Top = 24
If i = 1 Then
.Left = -(VBA.Format(DB, "w") - 1) * 18
Else
.Left = KHafta(i - 1).Left + KHafta(i - 1).Width
End If
.Width = 7 * 18
.Height = 12
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
End With
Next i
For i = 1 To GünAdet
Set KGün(i) = Me.Frame1.Controls.Add("Forms.Label.1")
With KGün(i)
.Caption = VBA.Format(VBA.DateAdd("d", (i - 1), DB), "dd")
.BackStyle = fmBackStyleOpaque
.BorderColor = &H80000016
If VBA.Format(VBA.DateAdd("d", (i - 1), DB), "w") = 1 Or VBA.Format(VBA.DateAdd("d", (i - 1), DB), "w") = 7 Then
.BackColor = &HC0C0C0
Else
.BackColor = &H8000000F
End If
.Top = 36
If i = 1 Then
.Left = 0
Else
.Left = KGün(i - 1).Left + KGün(i - 1).Width
End If
.Width = 18
.Height = 12
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
End With
Set KGünBar(i) = Me.Frame1.Controls.Add("Forms.Label.1")
With KGünBar(i)
.Caption = ""
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &HC0C0C0
.BackColor = &H8000000E
.Top = 48
If i = 1 Then
.Left = 0
Else
.Left = KGün(i - 1).Left + KGün(i - 1).Width
End If
.Width = 0.5
.Height = 800
.SpecialEffect = fmSpecialEffectFlat
End With
Next i
Frame1.BackColor = vbWhite
End Function
Sub EkranHazırla()

On Error Resume Next
With Me
.Height = 332
.Width = 726
.BackColor = vbWhite
End With
With Frame1
.Caption = ""
.ScrollBars = fmScrollBarsHorizontal
.SpecialEffect = fmSpecialEffectEtched
.Top = 36
.Left = 216
.Height = 264
.Width = 498
End With
With Frame2
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Top = -2
.Left = -2
.Height = 30
.Width = 992
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\BLOGSPOT\ZarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
.BackColor = vbWhite
With Label1
.Caption = "Mustafa ULUSARAÇ 01ulusarac@superonline.com"
.ForeColor = vbBlue
.Font.Bold = True
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.Top = 12
.Left = 30
.Height = 12
.Width = 240
End With
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = vbBlue
.BorderStyle = fmBorderStyleSingle
.Picture = LoadPicture("C:\Program Files\Microsoft Office\MEDIA\OFFICE11\BULLETS\BD14830_.gif")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.SpecialEffect = fmSpecialEffectFlat
.Top = 6
.Left = 6
.Height = 18
.Width = 18
End With
End With
With Frame3
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 36
.Width = 210
.Height = 48
With Label2
.Caption = "Dönem Başı ve Sonu tarihleri"
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Left = 6
.Top = 6
.Height = 18
.Width = 132
End With
With Label3
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Left = 138
.Top = 24
.Height = 18
.Width = 66
End With
With TextBox1
.ForeColor = vbBlue
.Font.Bold = True
.TextAlign = fmTextAlignCenter
.Top = 24
.Left = 6
.Height = 18
.Width = 66
.SpecialEffect = fmSpecialEffectEtched
End With
With TextBox2
.ForeColor = vbBlue
.Font.Bold = True
.TextAlign = fmTextAlignCenter
.Top = 24
.Left = 72
.Height = 18
.Width = 66
.SpecialEffect = fmSpecialEffectEtched
End With
With CommandButton1
.Caption = "Hesapla"
.Enabled = True
.Top = 6
.Left = 138
.Height = 18
.Width = 66
.SetFocus
End With
End With
With TreeView1
.Top = 84
.Left = 6
.Height = 204
.Width = 210
.Style = tvwTreelinesPlusMinusPictureText
.LineStyle = tvwRootLines
.Appearance = ccFlat
End With
Resimlik.ListImages.Add 1, "Resim1", Image1.Picture
Resimlik.ListImages.Add 2, "Resim2", Image1.Picture
End Sub

Hiç yorum yok:

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