Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

2 Ocak 2012 Pazartesi

CreatePolygonRgn Function


'UserForm1


'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B. Available Tools List
'1) Frame1
'2) Frame1\Image1, Label1, Label2
'3) Frame2
'4) Frame2\Label3, Label4, TextBox1, TextBox2, CommandButton1, CommandButton2
'5) Frame3
'6) Frame3\Image2, Label5, Label6, Label7, Label8
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private 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
Private hWind As Long
Private Ekran As New Class1
Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®] CreatePolygonRgn Function"
.Move (Application.Width - Me.Width) / 2, (Application.Height - Me.Height) / 2
End With
Application.Visible = False
Call Ekran_Kur
Set Ekran.Icon_Maker = Me
Set Ekran.Ekran0 = Me
Set Ekran.Ekran_Opague = Me
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
hWind = FindWindow(vbNullString, Me.Caption)
If Button = 1 Then
ReleaseCapture
SendMessage hWind, &HA1, 2, 0
End If
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Application.Visible = True
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
If TextBox1.Value = "mu" And TextBox2.Value = "pbid" Then
CommandButton1.Enabled = True
Else
CommandButton1.Enabled = False
End If
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
If TextBox1.Value = "mu" And TextBox2.Value = "pbid" Then
CommandButton1.Enabled = True
Else
CommandButton1.Enabled = False
End If
End Sub
Private Sub CommandButton1_Click() 'Open Program
On Error Resume Next
Set Ekran.Ekran_Transparent = Me
Unload Me
'UserForm2.Show
End Sub
Private Sub CommandButton2_Click() 'Close Program
On Error Resume Next
Set Ekran.Ekran_Transparent = Me
Unload Me
ThisWorkbook.Save
Application.Quit
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 262
.Width = 396
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
With Frame1
.Left = 6
.Top = 6
.Height = 138
.Width = 182
.Caption = ""
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectEtched
With Image1
.Top = 6
.Left = 60
.Height = 60
.Width = 60
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
End With
With Label1
.Left = 6
.Top = Image1.Top + Image1.Height + 6
.Height = 24
.Width = 168
.Caption = "Örnek İnşaat, Ticaret, Enerji, Turizm Yatırımları ve İşletmeleri A.Ş."
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignCenter
End With
With Label2
.Left = 6
.Top = Label1.Top + Label1.Height + 6
.Height = 24
.Width = 168
.Caption = "Örnek Projesi"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignCenter
End With
End With
With Frame2
.Left = 6
.Top = Frame1.Top + Frame1.Height + 6
.Height = 84
.Width = 182
.Caption = ""
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectEtched
With Label3
.Left = 6
.Top = 6
.Height = 18
.Width = 72
.Caption = " Username"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignLeft
End With
With TextBox1
.Left = Label3.Left + Label3.Width
.Top = Label3.Top
.Height = 18
.Width = 96
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = vbBlue
.TextAlign = fmTextAlignLeft
.PasswordChar = ""
.SetFocus
End With
With Label4
.Left = 6
.Top = Label3.Top + Label3.Height + 6
.Height = 18
.Width = 72
.Caption = " Password"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignLeft
End With
With TextBox2
.Left = Label4.Left + Label4.Width
.Top = Label4.Top
.Height = 18
.Width = 96
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = vbBlue
.TextAlign = fmTextAlignLeft
.PasswordChar = "*"
End With
With CommandButton1
.Left = TextBox2.Left + TextBox2.Width - 18 * 2 - 6
.Top = TextBox2.Top + TextBox2.Height + 6
.Height = 18
.Width = 18
.Caption = ""
.ControlTipText = "Program Girişi"
.Picture = Resim(URL2)
.PicturePosition = fmPicturePositionCenter
.Enabled = False
End With
With CommandButton2
.Left = TextBox2.Left + TextBox2.Width - 18
.Top = TextBox2.Top + TextBox2.Height + 6
.Height = 18
.Width = 18
.Caption = ""
.ControlTipText = "Program Çıkışı"
.Picture = Resim(URL4)
.PicturePosition = fmPicturePositionCenter
.Enabled = True
End With
End With
With Frame3
.Left = 204
.Top = 6
.Height = 114
.Width = 182
.Caption = ""
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectEtched
With Image2
.Top = 6
.Left = 72
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label5
.Left = 6
.Top = Image2.Top + Image2.Height + 6
.Height = 24
.Width = 168
.Caption = "PROGRAM BÜTÇELEME & İZLEME DEĞERLENDİRME"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.Font.Size = 9
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignCenter
End With
With Label6
.Left = 6
.Top = Label5.Top + Label5.Height + 6
.Height = 12
.Width = 168
.Caption = "Mustafa ULUSARAÇ"
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignCenter
End With
With Label7
.Left = 6
.Top = Label6.Top + Label6.Height
.Height = 12
.Width = 168
.Caption = "01ulusarac@superonline.com"
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignCenter
End With
With Label8
.Left = 6
.Top = Label7.Top + Label7.Height
.Height = 12
.Width = 168
.Caption = "Version 2.14"
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.WordWrap = True
.TextAlign = fmTextAlignCenter
End With
End With
End With
End Sub


'Module1


Option Explicit
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}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
Public Const URL3 As String = "http://2.bp.blogspot.com/-g5n-KmkMtW8/TmvRrcyDWwI/AAAAAAAAC1Y/ykFDewhbCSw/s1600/Baret2.jpg"
Public Const URL4 As String = "http://3.bp.blogspot.com/_hsHTxo_5L8E/S_BJl3oV55I/AAAAAAAACZk/2fWlWMMJ-YQ/s1600/KapatGIF.gif"
Public URL As String
Sub Form_Aç() '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
'Sub References_List()
' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References
' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1
' Next Eleman
'End Sub


'Class1


Option Explicit
Private i As Single
Private Type POINTAPI
X As Long
Y As Long
End Type
Private PA1(0 To 3) As POINTAPI
Private PA2(0 To 3) As POINTAPI
Private PA3(0 To 3) As POINTAPI
Private PA4(0 To 3) As POINTAPI
Private lRgn1 As Long
Private lRgn2 As Long
Private lRgn3 As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hPenceresind As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hPenceresind As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private hPict As Long
Private hWind As Long
Private lWind As Long
Public Property Set Icon_Maker(hForm As Object)
On Error Resume Next
hWind = FindWindow(vbNullString, hForm.Caption)
hPict = hForm.Image1.Picture.Handle
Call SendMessage(hWind, &H80, 0&, ByVal hPict)
Call SendMessage(hWind, &H80, 1&, ByVal hPict)
End Property
Public Property Set Ekran0(hForm As Object)
On Error Resume Next
hWind = FindWindow(vbNullString, hForm.Caption)
PA1(0).X = 0
PA1(0).Y = 0
PA1(1).X = 0
PA1(1).Y = hForm.Height * 4 / 3
PA1(2).X = hForm.Width * 4 / 3
PA1(2).Y = hForm.Height * 4 / 3
PA1(3).X = hForm.Width * 4 / 3
PA1(3).Y = 0
lRgn1 = CreatePolygonRgn(PA1(0), 4, 1)
lRgn1 = CreateRoundRectRgn(PA1(0).X, PA1(0).Y, PA1(2).X, PA1(2).Y, PA1(3).Y, PA1(3).Y)
PA2(0).X = 2
PA2(0).Y = 22* 4 / 3
PA2(1).X = 2
PA2(1).Y = hForm.Height * 4 / 3 - 2
PA2(2).X = (6 + hForm.Frame1.Width + 6) * 4 / 3
PA2(2).Y = hForm.Height * 4 / 3 - 2
PA2(3).X = (6 + hForm.Frame1.Width + 6) * 4 / 3
PA2(3).Y = 22 * 4 / 3
lRgn2 = CreatePolygonRgn(PA2(0), 4, 1)
lRgn2 = CreateRoundRectRgn(PA2(0).X, PA2(0).Y, PA2(2).X, PA2(2).Y, PA2(3).Y, PA2(3).Y)
PA3(0).X = (6 + hForm.Frame1.Width + 6 + 6) * 4 / 3
PA3(0).Y = 22 * 4 / 3
PA3(1).X = (6 + hForm.Frame1.Width + 6 + 6) * 4 / 3
PA3(1).Y = (22 + 6 + hForm.Frame3.Height + 6) * 4 / 3
PA3(2).X = hForm.Width * 4 / 3 - 2
PA3(2).Y = (22 + 6 + hForm.Frame3.Height + 6) * 4 / 3
PA3(3).X = hForm.Width * 4 / 3 - 2
PA3(3).Y = 22 * 4 / 3
lRgn3 = CreatePolygonRgn(PA3(0), 4, 1)
lRgn3 = CreateRoundRectRgn(PA3(0).X, PA3(0).Y, PA3(2).X, PA3(2).Y, PA3(3).Y, PA3(3).Y)
lWind = CombineRgn(lRgn1, lRgn2, lRgn3, 3)
lWind = SetWindowRgn(hWind, lRgn1, True)
hForm.Repaint
End Property
Public Property Set Ekran1(hForm As Object) '[+,+,+]Küçük Açar
On Error Resume Next
SetWindowLong hWind, (-16), GetWindowLong(hWind, (-16)) Or &H80000 Or &H20000 Or &H10000
DrawMenuBar hWind
ShowWindow hWind, 5
SetFocus hWind
End Property
Public Property Set Ekran_Opague(hForm As Object)
On Error Resume Next
hWind = FindWindow(vbNullString, hForm.Caption)
For i = 0 To 255 Step 0.1
lWind = GetWindowLong(hWind, (-20))
lWind = lWind Or &H80000 Or &H20000 Or &H10000
SetWindowLong hWind, (-20), lWind
DrawMenuBar hWind
SetLayeredWindowAttributes hWind, 0, i, &H2
ShowWindow hWind, 5
DoEvents
Next i
End Property
Public Property Set Ekran_Transparent(hForm As Object)
On Error Resume Next
hWind = FindWindow(vbNullString, hForm.Caption)
For i = 100 To 255 Step 0.1
lWind = GetWindowLong(hWind, (-20))
lWind = lWind Or &H80000 Or &H20000 Or &H10000
SetWindowLong hWind, (-20), lWind
ShowWindow hWind, 5
DrawMenuBar hWind
SetLayeredWindowAttributes hWind, 0, (255 - i), &H2
DoEvents
Next i
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