Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ekim 2006 Cuma

Eliptik UserForm




'UserForm1

Option Explicit
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Dim FormhWnd, EliptikHandle As Long
Dim i As Integer
Dim PauseTime, Start
Private Sub UserForm_Initialize()
    On Error Resume Next
    With Me
        .Width = 380
        .Height = 380
        .BackColor = VBA.RGB(0, 0, 255)
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
        FormhWnd = FindWindowA(vbNullString, .Caption)
        EliptikHandle = CreateEllipticRgn(110, 100, .Width, .Height)
    End With
    Call SetWindowRgn(FormhWnd, EliptikHandle, True)
End Sub
Private Sub UserForm_Activate()

    On Error Resume Next
    Application.StatusBar = " PBİD ®"
    Call UserForm_Layout
End Sub
Private Sub UserForm_Layout()

    On Error Resume Next
    PauseTime = 1
    Start = VBA.Timer
    Do While ((Start + PauseTime) > VBA.Timer)
        VBA.DoEvents
    Loop
    For i = 1 To 380
        With Me
            .Top = .Top - 1
            .Left = .Left - 1
            .Height = .Height - 1
            .Width = .Width - 1
            .Repaint
        End With
    Next i
    With Me
        .Height = 320
        .Width = 320
        .StartUpPosition = 2
    End With
    Unload Me
    Application.StatusBar = False
End Sub

10 Ekim 2006 Salı

PopUp Menu 2




'UserForm1

Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal hWnd As Long, ByVal lptpm As Any) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&
Dim hMenu As Long
Dim hWnd As Long
Private Sub UserForm_Initialize()
Me.Caption = "[PBİD®]PopUp Menu2 düzenleme...
hWnd = FindWindow(vbNullString, Me.Caption)
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Pt As POINTAPI
Dim ret As Long
If Button = 2 Then
hMenu = CreatePopupMenu()
AppendMenu hMenu, MF_STRING, 1, "Menu - 1"
AppendMenu hMenu, mfRTF, 2, "Menu - 2"
AppendMenu hMenu, MF_STRING, 3, "Menu - 3"
AppendMenu hMenu, MF_CHECKED, 4, "Menu - 4"
AppendMenu hMenu, MF_SEPARATOR, 5, ByVal 0&
AppendMenu hMenu, MF_STRING, 6, "[Mustafa ULUSARAÇ] 01ulusarac@superonline.com"
GetCursorPos Pt
ret = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON,Pt.X, Pt.Y, hWnd, ByVal 0&)
DestroyMenu hMenu
Select Case ret
Case 1
Call MenuProc1
Case 2
Call MenuProc2
Case 4
Call MenuProc3
End Select
End If
End Sub
Private Sub MenuProc1()
MsgBox "PopUp menu-1 is activated !"
End Sub
Private Sub MenuProc2()
MsgBox "PopUp menu-2 is activated !"
End Sub
Private Sub MenuProc3()
MsgBox "Prepared by Raider ®"
End Sub

1 Ekim 2006 Pazar

Popup Menu 1




'UserForm1

Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal hWnd As Long, ByVal lptpm As Any) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&
Dim hMenu As Long
Dim hWnd As Long
Dim Pt As POINTAPI
Dim ret As Long
Private Sub UserForm_Initialize()
On Error Resume Next
hWnd = FindWindow(vbNullString, Me.Caption)
Me.Caption = "[PBİD®] PopUp Menü1 düzenleme"
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If Button = 2 Then
hMenu = CreatePopupMenu()
AppendMenu hMenu, MF_STRING, 1, "Menü1"
AppendMenu hMenu, MF_STRING, 2, "Menü2"
AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0&
AppendMenu hMenu, MF_STRING, 4, "[Mustafa ULUSARAÇ] 01ulusarac@superonline.com"
GetCursorPos Pt
ret = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, Pt.X, Pt.Y, hWnd, ByVal 0&)
DestroyMenu hMenu
Select Case ret
Case 1
Call Menü1_Komut
Case 2
Call Menü2_Komut
Case 4
Call Menü3_Komut
End Select
End If
End Sub
Private Sub Menü1_Komut()
On Error Resume Next
MsgBox "PopUp MENÜ1 !"
End Sub
Private Sub Menü2_Komut()
On Error Resume Next
MsgBox "PopUp MENÜ2 !"
End Sub
Private Sub Menü3_Komut()
On Error Resume Next
MsgBox "AÇIKLAMA"
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