Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Mart 2011 Perşembe

UserForm Effects





'UserForm1

'A) Tools\Macro\Security Otions [Picture: 1]
'B) Windows XP® Office 2003® Normal Referance List

    'Description: Visual Basic For Applications
    'Description: Microsoft Excel 11.0 Object Library
    'Description: OLE Automation
    'Description: Microsoft Office 11.0 Object Library
    'Description: Microsoft Forms 2.0 Object Library
'C) UserForm1'e Eklenen Araçlar (Add Tools)
    'Frame1
    'Frame1\Image1, Label1, Image2
    'Image3

Option Explicit
Private Maskeleme As Class1
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] UserForm Effects"
    Application.Visible = False
    Application.VBE.MainWindow.Visible = False
    Call EkranDüzenle
    Set Maskeleme = New Class1
    Set Maskeleme.Ekran1 = Me
    Call Maskeleme.Serigrafik_Ekran(Me, vbBlack) 'Serigrafik Renk
    Call Maskeleme.Ekran_Netleme
End Sub
Private Sub UserForm_Activate()

    On Error Resume Next
    With Me
        .Left = (Application.Width - .Width) / 2
        .Top = (Application.Height - .Height) / 2
    End With
    DoEvents
    EffectTip = InputBox("Total [1] / Local Effcet [2]", "[PBİD®] Effect to Choose", 1, Me.Top + Me.Height, Me.Left)
End Sub
Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    On Error Resume Next
    X1 = VBA.Round(X / 0.748, 0): Y1 = VBA.Round(Y / 0.748, 0)
    Set Maskeleme.Alan_Kumlama = Me
End Sub
Private Sub Image3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    On Error Resume Next
    X1 = VBA.Round(X / 0.748, 0): Y1 = VBA.Round(Y / 0.748, 0)
    Set Maskeleme.Alan_Kumlama = Me
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")
        .MousePointer = fmMousePointerIBeam
    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.Kumlanacak_Alan(Button, Shift, X, Y)
End Sub
Private Sub EkranDüzenle()

    On Error Resume Next
    With Me
        .Height = (6 * 50) * 1.2
        .Width = (6 * 75) * 1.2
        .BackColor = vbBlack
        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®] UserForm Effects"
            .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
            .BorderStyle = fmBorderStyleNone
            .Left = 0
            .Top = Frame1.Top + Frame1.Height + 6
            .Height = Me.InsideHeight - .Top
            .Width = Me.InsideWidth
            .Picture = Resim(URL4)
            .PictureAlignment = fmPictureAlignmentCenter
            .PictureSizeMode = fmPictureSizeModeStretch
            .PictureTiling = False
        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 GetDC Lib "user32" (ByVal hWnd 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 SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Apsis As Long, Ordinat As Long, i As Long, ii As Long, Alan As Long, Renk As Long
Public SatırSayısı As Double, KolonSayısı As Double
Public Red As Integer, Green As Integer, Blue As Integer
Public X1 As Double, Y1 As Double
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 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 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://1.bp.blogspot.com/_hsHTxo_5L8E/S_EWTHoBeBI/AAAAAAAACaM/I9d5_UGPWqg/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/S_EV6tEGhyI/AAAAAAAACZ8/9mQAo3LcyUE/s1600/KapatMaviFif.gif" 'Microsoft Office Excel® Kod Kılavuzu [Kapat]
Public Const URL4 As String = "
http://3.bp.blogspot.com/_hsHTxo_5L8E/S_EV-ACj8QI/AAAAAAAACaE/kBI71lI7-iY/s1600/UserFormEffectsGIF.gif" 'Microsoft Office Excel® Kod Kılavuzu [Effect]
Public EffectTip As Double
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
Private Çerçeve As Long, Yoğunluk As Long
Public Sub Serigrafik_Ekran(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
        Serigrafik_Pencere AraYüzBölgesi, 0
    End If
End Sub
Private Sub Serigrafik_Pencere(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 Serigrafik_Alan(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
                    VBA.DoEvents
                End If
            End If
        Next Apsis
    Next Ordinat
    Serigrafik_Alan = MaskeliBölge
End Function
Public Sub Ekran_Netleme()

    On Error Resume Next
    AraYüz.Repaint
    If AraYüzBölgesi <> 0 Then
        Çerçeve = GetDC(AraYüzBölgesi)
        MaskeBölgesi = Serigrafik_Alan(Ç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
            Serigrafik_Pencere AraYüzBölgesi, Yoğunluk
        Next Yoğunluk
        For Yoğunluk = 5 To 255 Step 5
            DoEvents
            Serigrafik_Pencere AraYüzBölgesi, Yoğunluk
        Next Yoğunluk
        Serigrafik_Pencere 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 Kumlanacak_Alan(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
Public Property Set Alan_Kumlama(Ekran As Object) 'Sand Effect

    On Error Resume Next
    Red = 40: Green = 60: Blue = 120
    Alan = GetDC(FindWindow(vbNullString, Ekran.Caption))
    KolonSayısı = VBA.Round(Ekran.InsideWidth / 0.748, 0)
    SatırSayısı = VBA.Round(Ekran.InsideHeight / 0.748, 0)
    ReDim Bellek(1 To SatırSayısı, 1 To KolonSayısı)
    If EffectTip <> 2 Then
        For i = 1 To KolonSayısı
            For ii = (Ekran.Frame1.Height / 0.748) To (SatırSayısı - (Ekran.Frame1.Height / 0.748))
                Apsis = (i * VBA.Rnd)
                Ordinat = (ii * (1 + VBA.Rnd))
                If GetPixel(Alan, Apsis, Ordinat) <> vbWhite And GetPixel(Alan, Apsis, Ordinat) <> vbRed And GetPixel(Alan, Apsis, Ordinat) <> vbBlue Then
                    SetPixel Alan, Apsis, Ordinat, VBA.RGB(Red, Green, Blue) * (1 + VBA.Rnd)
                End If
                DoEvents
            Next ii
            DoEvents
         Next i
    Else
        For i = 1 To KolonSayısı
            For ii = (Ekran.Frame1.Height / 0.748) To (SatırSayısı - (Ekran.Frame1.Height / 0.748))
                Apsis = i
                Ordinat = ii
                If (Apsis > (X1 - 6) And Apsis < (X1 + 6)) Then
                    Red = 40: Green = 160: Blue = 120
                    SetPixel Alan, Apsis, Ordinat, VBA.RGB(Red, Green, Blue) * (1 + VBA.Rnd)
                Else
                    Red = 0: Green = 0: Blue = 0
                    SetPixel Alan, Apsis, Ordinat, VBA.RGB(Red, Green, Blue) * (1 + VBA.Rnd)
                End If
                DoEvents
            Next ii
            DoEvents
        Next i
    End If
End Property


1 yorum:

serkan dedi ki...

Teşekkürler

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