Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Mayıs 2010 Cumartesi

Serigraphic (Serigrafik) UserForm



'UserForm1

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

'Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'Description: OLE Automation, FullPath: C:\WINDOWS\system32\stdole2.tlb
'Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL

'B) UserForm1'e Eklenen Araçlar (Add Tools)

'Frame1
'Frame1\Image1, Label1, Image2
'Image3
'Frame2
'Frame2\Label2

Option Explicit
Private Maskeleme As Class1
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Serigrafik UserForm"
Application.Visible = False
Set Maskeleme = New Class1
Set Maskeleme.Ekran1 = Me
Call EkranDüzenle
Set Maskeleme = New Class1
Call Maskeleme.EkranYükleme(Me, vbWhite) 'Serigrafik Renk
Call Maskeleme.EkranGösterme

End Sub
Private Sub UserForm_Terminate()

On Error Resume Next
Application.Visible = True
Set Maskeleme = Nothing

End Sub
Private Sub Image2_Click()

On Error Resume Next
Unload Me

End Sub
Private Sub Image2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
With Label1

.MousePointer = fmMousePointerCustom
.MouseIcon = LoadPicture("C:\WINDOWS\Cursors\harrow.cur")

End With

End Sub
Private Sub Frame1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Call Maskeleme.AraYüzFareAşağıKomutu(Button, Shift, X, Y)

End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 448
.Width = 412
.BackColor = vbWhite
With Frame1

.Caption = ""
.BackColor = vbWhite
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
.Left = 0
.Top = 0
.Height = 24
.Width = Me.InsideWidth
With Image1

.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Top = 3
.Left = 3
.Height = 18
.Width = 18
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False

End With
With Label1

.AutoSize = True
.WordWrap = False
.Caption = "[PBİD®] Serigrafik UserForm"
.TextAlign = fmTextAlignCenter
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = Frame1.Width / 2 - .Width / 2
.Top = 6
.Height = 12
.Font.Bold = True
.ForeColor = &HC0C000

End With
With Image2

.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Top = 3
.Left = Frame1.Width - 18 - 6
.Height = 18
.Width = 18
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False

End With

End With
With Image3

.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Top = 36
.Left = 0
.Height = Me.InsideHeight - 36 - 24
.Width = Me.InsideWidth
.Picture = Resim(URL8)
.PictureSizeMode = fmPictureSizeModeStretch
.PictureAlignment = fmPictureAlignmentCenter
.PictureTiling = False

End With
With Frame2

.Caption = ""
.BackColor = vbWhite
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
.Left = 0
.Top = Image3.Top + Image3.Height
.Height = 24
.Width = Me.InsideWidth
With Label2

.AutoSize = True
.WordWrap = False
.Caption = "Mustafa ULUSARAÇ 01ulusarac@superonline.com"
.TextAlign = fmTextAlignCenter
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = Frame1.Width / 2 - .Width / 2
.Top = 6
.Height = 12
.Font.Bold = True
.ForeColor = &HC0C000

End With

End With

End With

End Sub

'Module1

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewIndex As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S9s14D8kVsI/AAAAAAAACWs/iJs-dS0fO9M/s1600/Bant2.bmp" 'Microsoft Office Excel® Kod Kılavuzu [Bant]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD]
Public Const URL3 As String = "http://4.bp.blogspot.com/_hsHTxo_5L8E/S9s_33-3g3I/AAAAAAAACW0/39p3uPjjurE/s1600/Kapat_gif.gif" 'Microsoft Office Excel® Kod Kılavuzu [Kapat]
Public Const URL4 As String = "http://upload.wikimedia.org/wikipedia/en/2/24/Centennial_logo_of_Fenerbah%C3%A7e_S.K.jpg" '[Fenerbahçe]
Public Const URL5 As String = "http://www.ozkantigli.com/wp-content/uploads/2009/06/logo_galatasaray.jpg" '[Galatasaray]
Public Const URL6 As String = "http://www.guzelresimler.org/data/media/125/Besiktas-Logo.jpg" '[Beşiktaş]
Public Const URL7 As String = "http://www.logodesignworks.com/logo-designs/logo-design-t/main/Trabzonspor.gif" '[Trabzon Spor]
Public Const URL8 As String = "http://web.clark.edu/mceriello/MUN/un.gif" '[United National]
Sub FormAç() 'Open UserForm

On Error Resume Next
Load UserForm1

End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim

End Function

'Class1

Option Explicit
Private WithEvents AraYüz As MSForms.UserForm
Private SergrafikRenk As Long, AraYüzBölgesi As Long, MaskeBölgesi As Long, ÇerçeveBölgesi As Long
Private MaskeliBölge As Long, EldekiBölge As Long, BaşlamaNoktası As Long, BaşlamaBölgesi As Boolean, RenkNoktası As Long, Apsis As Long, Ordinat As Long
Private Çerçeve As Long, Yoğunluk As Long
Public Sub EkranYükleme(ByRef Ekran As Object, ByVal Renk As Long)

On Error Resume Next
Set AraYüz = Ekran
SergrafikRenk = Renk
Ekran.BorderStyle = fmBorderStyleNone
Ekran.BackColor = SergrafikRenk
AraYüzBölgesi = FindWindow(vbNullString, Ekran.Caption)
If AraYüzBölgesi <> 0 Then

SetWindowLong AraYüzBölgesi, -16, GetWindowLong(AraYüzBölgesi, -16) And Not &H400000
DrawMenuBar AraYüzBölgesi
PencereSerigrafi AraYüzBölgesi, 0

End If

End Sub
Private Sub PencereSerigrafi(ByVal Pencere As Long, ByVal Karakter As Byte)

On Error Resume Next
SetWindowLong Pencere, (-20), GetWindowLong(Pencere, (-20)) Or &H80000
SetLayeredWindowAttributes Pencere, ByVal 0&, Karakter, &H2

End Sub
Private Function BölgeselSerigrafi(ByVal Nokta As Long, ByVal SBoy As Long, ByVal SEn As Long, ByVal Renk As Long) As Long

On Error Resume Next
MaskeliBölge = CreateRectRgn(0, 0, 0, 0)
For Ordinat = 0 To SBoy - 1

BaşlamaNoktası = 0
BaşlamaBölgesi = False
For Apsis = 0 To SEn

RenkNoktası = GetPixel(Nokta, Apsis, Ordinat)
If RenkNoktası <> Renk And RenkNoktası <> &HFFFFFFFF Then

If BaşlamaBölgesi = False Then

BaşlamaBölgesi = True
BaşlamaNoktası = Apsis

End If

Else

If BaşlamaBölgesi = True Then

EldekiBölge = CreateRectRgn(BaşlamaNoktası + 3 + 1, Ordinat + 3 + 1, Apsis + 3, Ordinat + 3)
Call CombineRgn(MaskeliBölge, MaskeliBölge, EldekiBölge, 2)
Call DeleteObject(EldekiBölge)
BaşlamaBölgesi = False

End If

End If

Next Apsis

Next Ordinat
BölgeselSerigrafi = MaskeliBölge

End Function
Public Sub EkranGösterme()

On Error Resume Next
AraYüz.Repaint
If AraYüzBölgesi <> 0 Then

Çerçeve = GetDC(AraYüzBölgesi)
MaskeBölgesi = BölgeselSerigrafi(Çerçeve, AraYüz.InsideHeight / 0.748, AraYüz.InsideWidth / 0.748, SergrafikRenk)
ÇerçeveBölgesi = SetWindowRgn(AraYüzBölgesi, MaskeBölgesi, True)
ReleaseDC AraYüzBölgesi, Çerçeve
For Yoğunluk = 1 To 255

DoEvents
PencereSerigrafi AraYüzBölgesi, Yoğunluk

Next Yoğunluk
For Yoğunluk = 5 To 255 Step 5

DoEvents
PencereSerigrafi AraYüzBölgesi, Yoğunluk

Next Yoğunluk
PencereSerigrafi AraYüzBölgesi, 255

End If

End Sub
Private Sub Class_Terminate()

On Error Resume Next
If AraYüzBölgesi <> 0 Then

DeleteObject ÇerçeveBölgesi
DeleteObject MaskeBölgesi
SetWindowLong AraYüzBölgesi, -16, GetWindowLong(AraYüzBölgesi, -16) Or &H400000

End If
Set AraYüz = Nothing

End Sub
Public Sub AraYüzFareAşağıKomutu(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
If Button = 1 Then

If AraYüzBölgesi <> 0 Then

ReleaseCapture
SendMessage AraYüzBölgesi, &HA1, 2, 0

End If

End If

End Sub
Public Property Set Ekran1(Ekran As Object) '[+,+,+]Küçük Açar

On Error Resume Next
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-16), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-16)) Or &H80000 Or &H20000 Or &H10000
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
ShowWindow FindWindow(vbNullString, Ekran.Caption), 5
SetFocus FindWindow(vbNullString, Ekran.Caption)

End Property
Public Property Set Ekran2(Ekran As Object) '[+,+,+]Büyük Açar

On Error Resume Next
SetWindowLong FindWindow(vbNullString, Ekran.Caption), (-16), GetWindowLong(FindWindow(vbNullString, Ekran.Caption), (-16)) Or &H80000 Or &H20000 Or &H10000
DrawMenuBar FindWindow(vbNullString, Ekran.Caption)
ShowWindow FindWindow(vbNullString, Ekran.Caption), 3
SetFocus FindWindow(vbNullString, Ekran.Caption)

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