Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Temmuz 2009 Pazartesi

Resizable UserForm [Manuel]



'UserForm1

Option Explicit
Dim A1, A2
Dim B1, B2
Dim EkranDüzenleme As New Class1
Private Sub UserForm_Initialize()

On Error Resume Next
Me.BackColor = RGB(251, 241, 241)
Me.Caption = "[PBİD ®] Resizable UserForm"
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
Set EkranDüzenleme.ÇerçeveDüzenleme = Me
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Call Boyut
If X >= (A2 - 24) And (B2 - 24) > Y Then
Me.MousePointer = fmMousePointerSizeWE
If Button = 1 Then Me.Width = X + (A1 - A2)
Else
If (A2 - 24) > X And Y >= (B2 - 24) Then
Me.MousePointer = fmMousePointerSizeNS
If Button = 1 Then Me.Height = Y + (B1 - B2)
Else
If X >= (A2 - 24) Or Y >= (B2 - 24) Then
Me.MousePointer = fmMousePointerSizeNWSE
If Button = 1 Then Me.Width = X + (A1 - A2): Me.Height = Y + (B1 - B2)
Else
Me.MousePointer = fmMousePointerArrow
End If
End If
End If
VBA.DoEvents
Call Boyut
End Sub
Private Sub Boyut()

On Error Resume Next
A1 = Me.Width
A2 = Me.InsideWidth
B1 = Me.Height
B2 = Me.InsideHeight
End Sub

'Class1

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (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
Private Çerçeve As Long
Private Tarz As Long
Public Property Set ÇerçeveDüzenleme(Ekran As Object)

On Error Resume Next
Çerçeve = FindWindow(vbNullString, Ekran.Caption)
Call Çerçeve1
End Property
Private Sub Çerçeve1()

On Error Resume Next
Tarz = GetWindowLong(Çerçeve, (-16))
Tarz = Tarz Or &H80000 Or &H20000 Or &H10000
SetWindowLong Çerçeve, (-16), Tarz
ShowWindow Çerçeve, 5
DrawMenuBar Çerçeve
End Sub 

10 Temmuz 2009 Cuma

Digital Clock On Sheet




'Module1

Option Explicit
Dim Hücre As Range
Dim Durdur As Boolean, Renk As Boolean

Sub SaatiBaşlat() '[Start Clock]
On Error Resume Next
Durdur = False
Set Hücre = ThisWorkbook.Worksheets("Sayfa1").Range("A1")
With Hücre
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Interior.ColorIndex = 5
With .Font
.Bold = True
.Size = 24
.Name = "Arial Tur"
.Size = 24
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 6
End With
End With
ThisWorkbook.Sheets("Sayfa1").ScrollArea = "A1"
Call Saat
End Sub
Sub Saat() '[Clock]
On Error Resume Next
If Durdur = True Then Exit Sub
If Renk = False Then
With Hücre
.Interior.ColorIndex = 6
.Font.ColorIndex = 5
End With
Renk = True
Else
With Hücre
.Interior.ColorIndex = 5
.Font.ColorIndex = 6
End With
Renk = False
End If
ThisWorkbook.Sheets("Sayfa1").Cells(1, 1).Value = Format(Now, "hh:mm:ss")
Application.OnTime (Now + TimeSerial(0, 0, 1)), "Saat"
End Sub
Sub SaatiDurdur() '[Stop Clock]
On Error Resume Next
Durdur = True
Set Hücre = ThisWorkbook.Worksheets("Sayfa1").Range("A1")
With Hücre
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Interior.ColorIndex = xlNone
With .Font
.Bold = False
.Name = "Arial Tur"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 0
End With
End With
ThisWorkbook.Sheets("Sayfa1").ScrollArea = ""
End Sub

1 Temmuz 2009 Çarşamba

Inside The File Folder To Find

'Module1

Option Explicit
Dim Klasör, BakılanDosya
Dim i As Integer, Mesaj As String
Sub KlasörİçindeDosyaBulmak() 'Inside The File Folder To Find

On Error Resume Next
Mesaj = ""
Klasör = "C:\Documents and Settings\PC\Desktop\BLOGSPOT\"
Set BakılanDosya = Application.FileSearch
With BakılanDosya

.LookIn = Klasör
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then

For i = 1 To .FoundFiles.Count

Mesaj = Mesaj & vbCrLf & .FoundFiles(i)

Next i
Mesaj = Mesaj & vbCrLf & "Toplam " & .FoundFiles.Count & " dosya bulundu."
MsgBox Mesaj & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®]Klasör İçinde İstenilen Türde Dosya Bulmak.."

Else

MsgBox "Belirtilen Klasörde Herhangi Bir Dosya Bulunamadı."

End If

End With

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