Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Haziran 2007 Pazar

UserForm System Menu [X] Control




'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Forms 2.0 Object Library
'B) UserForm1'e Eklenen Araçlar (Add Tools)
'Frame1
'Frame1\Image1, Label1, Label2
'CheckBox1, CommandButton1
Option Explicit
Dim EkranTipi As New Class1
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®]System Menu [X] Control"
Call EkranDüzenle
Set EkranTipi.EkranGörün = Me
Set EkranTipi.Ekran1 = Me
Me.CheckBox1.Value = True
Me.CheckBox1.Value = False
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
Me.StartUpPosition = 2
End Sub
Private Sub CheckBox1_Click()

On Error Resume Next
If CheckBox1.Value = False Then
Set EkranTipi.XKapat = Me
CommandButton1.Enabled = True
Else
Set EkranTipi.XAç = Me
CommandButton1.Enabled = False
End If
End Sub
Private Sub CommandButton1_Click()

On Error Resume Next
Set EkranTipi.EkranKaybol = Me
Me.Hide
Unload Me
Application.Visible = True
ActiveWorkbook.Save
'Application.Quit
End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 204
.Width = 228
.BackColor = &H8000000F
End With
With Frame1
.Caption = ""
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
If .Picture Is Nothing Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
If .Picture Is Nothing Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
End With
With CheckBox1
.Left = 114
.Top = 120
.Height = 24
.Width = 102
.Caption = "SM [X] Control"
.Alignment = fmAlignmentRight
If .Picture = 0 Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
.PicturePosition = fmPicturePositionLeftCenter
.SpecialEffect = fmButtonEffectSunken
.TextAlign = fmTextAlignLeft
End With
With CommandButton1
.Left = 114
.Top = 150
.Height = 24
.Width = 102
.Caption = "Kapat [Close]"
End With
End Sub

'Class1

Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Pencere_Düzeni As Long, ByVal Mesaj As Long, ByVal Değişken1 As Long, Değişken2 As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Pencere As Long, ByVal Koordinat As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal Pencere As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal Pencere As Long, ByVal Eylem As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal Pencere As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal Pencere As Long, ByVal Anahtar As Long, ByVal Yoğunluk As Byte, ByVal İkinci_İşaret As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal Pencere As Long, ByVal Eski_Durum As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal EkranMenü As Long, ByVal Pozisyon As Long, ByVal İlk_İşaret As Long) As Long
Dim i As Integer
Public Property Set Ekran1(Ekran As Object)

On Error Resume Next
SimgeYarat Ekran, FindWindow(vbNullString, Ekran.Caption), Ekran.Image1.Picture.Handle
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-16), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-16)) Or &H80000 Or &H20000 Or &H10000
ShowWindow FindWindow(vbNullString, Ekran.Caption), 5 '3
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
End Property
Public Property Set Form_Yok_Ol(Ekran As Object)

On Error Resume Next
SetWindowLong Form_Pencere, (-20), GetWindowLong(Form_Pencere, (-20)) Or &H80000
SetLayeredWindowAttributes Form_Pencere, 0, 1, &H2
End Property
Public Property Set EkranGörün(Ekran As Object)

On Error Resume Next
For i = 1 To 255
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-20), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-20)) Or &H80000
SetLayeredWindowAttributes FindWindow(vbNullString, Ekran.Caption), 0, i, &H2
ShowWindow FindWindow(vbNullString, Ekran.Caption), 5 '3
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
DoEvents
Next i
End Property
Public Property Set EkranKaybol(Ekran As Object)

On Error Resume Next
For i = 1 To 255
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-20), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-20)) Or &H80000
SetLayeredWindowAttributes FindWindow(vbNullString, Ekran.Caption), 0, (255 - i), &H2
ShowWindow FindWindow(vbNullString, Ekran.Caption), 5 '3
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
DoEvents
Next i
End Property
Private Function SimgeYarat(Form As Object, Başlık As Long, EkranSimge As Long)

On Error Resume Next
Call SendMessage(Başlık, &H80, 0&, ByVal EkranSimge)
Call SendMessage(Başlık, &H80, 1&, ByVal EkranSimge)
End Function
Public Property Set XAç(Ekran As Object)

On Error Resume Next
If Application.Version > 9 Then'Excel2000
DeleteMenu GetSystemMenu(FindWindow("ThunderDFrame", Ekran.Caption), 1), &HF060, 0&
DrawMenuBar FindWindow("ThunderDFrame", Ekran.Caption)
Else
DeleteMenu GetSystemMenu(FindWindow("ThunderXFrame", Ekran.Caption), 1), &HF060, 0&
DrawMenuBar FindWindow("ThunderXFrame", Ekran.Caption)
End If
End Property
Public Property Set XKapat(Ekran As Object)

On Error Resume Next
If Application.Version > 9 Then'Excel2000
DeleteMenu GetSystemMenu(FindWindow("ThunderDFrame", Ekran.Caption), 0), &HF060, 0&
DrawMenuBar FindWindow("ThunderDFrame", Ekran.Caption)

Else
DeleteMenu GetSystemMenu(FindWindow("ThunderXFrame", Ekran.Caption), 0), &HF060, 0&
DrawMenuBar FindWindow("ThunderXFrame", Ekran.Caption)
End If
End Property

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