Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Nisan 2011 Çarşamba

More Than Three Columns Array in Excel to Sort Data.







'Module1


'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

Option Explicit
Private Const Kayıt As Double = 600 'For Worksheet; Max 65536 rows
Private Const Kolon As Double = 6 'For Worksheet; Max 256 columns
Dim Elde As Variant, Sorgu As Variant, EldeS As Variant, SorguS As Variant, EldeÖ(1 To Kolon) As Variant, SorguÖ(1 To Kolon) As Variant, Rastgele As Variant
Dim i As Single, ii As Single, iii As Single, iv As Single, v As Single
Dim En As Integer, Boy As Integer
Dim Sayfa As Worksheet
Dim Ton As Double
Dim Bellek(1 To Kayıt, 1 To Kolon)
Dim Sorgulama As Double
Dim Adres As String
Sub Süz() 'to filter
            On Error Resume Next
            Call Temizle
            For i = 1 To Kayıt
                        For ii = 1 To Kolon
                                   If ii = 1 Then
                                               Bellek(i, ii) = i
                                   ElseIf ii = 2 Then
                                               Rastgele = VBA.Round(VBA.Rnd * 10, 0)
                                               Bellek(i, ii) = VBA.Switch(Rastgele = 0, "A", Rastgele = 1, "B", Rastgele = 2, "C", Rastgele = 3, "D", Rastgele = 4, "E", Rastgele = 5, "F", Rastgele = 6, "G", Rastgele = 7, "H", Rastgele = 8, "I", Rastgele = 9, "J", Rastgele > 9, "K")
                                   Else
                                               Rastgele = VBA.Round(VBA.Rnd * 10, 0)
                                               Bellek(i, ii) = Rastgele
                                   End If
                        Next ii
            Next i
            Sheets("Data").Select
            Range(Cells(2, 1), Cells(601, Kolon)).Select
            Adres = Application.Selection.Address
            Sheets("Data").Range(Adres) = Bellek
            Call Gruplama(Bellek, Kolon, Kayıt, Sheets("Data"))
            Call Süzgeç(Bellek, Kolon, Kayıt)
            Sheets("SortDataMax256Columns").Range(Adres) = Bellek
            Call Gruplama(Bellek, Kolon, Kayıt, Sheets("SortDataMax256Columns"))
            Call Kontrol
End Sub
Private Function Süzgeç(Bellek, En, Boy) 'Filter
            On Error Resume Next
            For i = 1 To Boy
                       For ii = 1 To En
                                   Sorgu = Bellek(i, ii)
                                   For v = (ii - 1) To 1 Step -1
                                              SorguÖ(v) = Bellek(i, (ii - v))
                                  Next v
                                  For iii = (i + 1) To Boy
                                               Elde = Bellek(iii, ii)
                                               For v = (ii - 1) To 1 Step -1
                                                           EldeÖ(v) = Bellek(iii, (ii - v))
                                               Next v
                                               Sorgulama = 1
                                              If ii > 2 Then
                                                           For v = 1 To (ii - 2)
                                                                       If SorguÖ(v) = EldeÖ(v) Then Sorgulama = Sorgulama * 1
                                                                       If SorguÖ(v) <> EldeÖ(v) Then Sorgulama = Sorgulama * 0
                                                           Next v
                                               End If
                                               If Sorgu > Elde And Sorgulama = 1 Then
                                                           Bellek(i, ii) = Elde
                                                           Bellek(iii, ii) = Sorgu
                                                           Sorgu = Elde
                                                           For iv = 1 To En
                                                                       If iv <> ii Then
                                                                                  SorguS = Bellek(i, iv)
                                                                                  EldeS = Bellek(iii, iv)
                                                                                  Bellek(i, iv) = EldeS
                                                                                  Bellek(iii, iv) = SorguS
                                                                       End If
                                                           Next iv
                                               End If
                                    Next iii
                                   Application.StatusBar = "Total Progress: [" & i & "/" & Boy & "] " & i & ". Item Progress: [" & ii & "/" & En & "]"
                                   DoEvents
                        Next ii
                        Application.StatusBar = "Total Progress: [" & i & "/" & Boy & "] " & i & ". Item Progress: [" & ii & "/" & En & "]"
                        DoEvents
            Next i
End Function
Private Function Gruplama(Bellek, En, Boy, Sayfa) 'to group
            On Error Resume Next
            For i = 1 To Boy
                       Select Case Bellek(i, 2)
                       Case "A": Ton = 35
                       Case "B": Ton = 36
                       Case "C": Ton = 37
                       Case "D": Ton = 38
                       Case "E": Ton = 39
                       Case "F": Ton = 40
                       Case "G": Ton = 41
                       Case "H": Ton = 42
                       Case "I": Ton = 43
                       Case "J": Ton = 44
                       Case "K": Ton = 45
                       End Select
                       For ii = 1 To En
                                   Sayfa.Cells((i + 1), ii).Interior.ColorIndex = Ton
                       Next ii
            Next i
End Function
Private Sub Kontrol() 'Control
            On Error Resume Next
            Sheets("Data").Select
            Range(Adres).Copy
            Sheets("ExcelSort3Columns").Select
            Range(Adres).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           Range(Cells(1, 1), Cells(601, Kolon)).Select
           Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("D2"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
           Call Gruplama(Bellek, Kolon, Kayıt, Sheets("ExcelSort3Columns"))
           Range("A1").Select
End Sub
Private Sub Temizle() 'to clean
           On Error Resume Next
           Sheets("Data").Select
           If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "Data": VBA.Err.Number = 0
            Sheets("ExcelSort3Columns").Select
            If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "ExcelSort3Columns": VBA.Err.Number = 0
           Sheets("SortDataMax256Columns").Select
           If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "SortDataMax256Columns": VBA.Err.Number = 0
           Sheets("Control").Select
           If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "Control": VBA.Err.Number = 0
            Sheets(Array("Data", "SortDataMax256Columns", "ExcelSort3Columns", "Control")).Select
            Cells.Select
            Selection.Delete Shift:=xlUp
           Sheets("Data").Activate
           Range("A1").Select
           With Selection
                        .FormulaR1C1 = "Caption1"
                        With .Characters(Start:=1, Length:=8).Font
                                   .Name = "Arial"
                                   .FontStyle = "Normal"
                                   .Size = 8
                                   .ColorIndex = 2
                        End With
                        .HorizontalAlignment = xlCenter
                       .VerticalAlignment = xlCenter
                       .WrapText = True
                       .Orientation = 90
                       .IndentLevel = 0
                       .ReadingOrder = xlContext
                       .Font.ColorIndex = 2
                       .Interior.ColorIndex = 5
                       .AutoFill Destination:=Rows("1:1"), Type:=xlFillDefault
            End With
            Range("A2").Select
            ActiveWindow.FreezePanes = False: ActiveWindow.FreezePanes = True
            For i = 1 To ThisWorkbook.Worksheets.Count
                        Sheets(i).Select
                       ActiveSheet.Rows("1:1").RowHeight = 45.75
                       Cells.Select
                       With Selection
                                   .Font.Name = "Arial"
                                   .Font.Size = 8
                                   .ColumnWidth = 3
                       End With
            Next i
            Sheets("Control").Select
            For i = 1 To Kayıt
                       For ii = 1 To Kolon
                                   If ii = 2 Then
                                               Cells(i + 1, ii).FormulaR1C1 = "=EXACT(SortDataMax256Columns!RC,ExcelSort3Columns!RC)"
                                               Cells(i + 1, ii).FormatConditions.Delete
                                               Cells(i + 1, ii).FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="TRUE"
                                               Cells(i + 1, ii).FormatConditions(1).Interior.ColorIndex = 3
                                   Else
                                               Cells(i + 1, ii).FormulaR1C1 = "=SortDataMax256Columns!RC-ExcelSort3Columns!RC"
                                               Cells(i + 1, ii).FormatConditions.Delete
                                               Cells(i + 1, ii).FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="0"
                                               Cells(i + 1, ii).FormatConditions(1).Interior.ColorIndex = 3
                                   End If
                       Next ii
            Next i
           Selection.Rows("1:1").RowHeight = 45.75: Sheets("Control").Columns("A:B").ColumnWidth = 4: Range("A1").Select
End Sub
Private Sub AlanTemizle() 'Area clean
            On Error Resume Next
            Sheets("Data").Range("A2:IV65536").ClearContents
            Sheets("Data").Range("A2:IV65536").Interior.ColorIndex = xlNone
            Sheets("ExcelSort3Columns").Range("A2:IV65536").ClearContents
            Sheets("ExcelSort3Columns").Range("A2:IV65536").Interior.ColorIndex = xlNone
            Sheets("SortDataMax256Columns").Range("A2:IV65536").ClearContents
            Sheets("SortDataMax256Columns").Range("A2:IV65536").Interior.ColorIndex = xlNone
            Sheets("Data").Select
            Range("A1").Select
End Sub

10 Nisan 2011 Pazar

UserForm Painting By SetPixel Function






'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
    'Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\WINDOWS\system32\MSCOMCTL.OCX
'B) UserForm1'e Eklenen Araçlar (Add Tools)
    'Image1, Label1, Label2
    'Label3, Label4, Image2
    'Label5, Label6, Label7, Label8
    'Label9, Label10, Label11, Label12
    'Label13, Label14, Label15, Label16
    'ProgressBar1, Label17
    'ProgressBar2, Label18
    'CommandButton1
    'Label19, Label20
    'Label21, Label22
    'Label23, Label24, Label25, Label26, Label27, Label28

Option Explicit
Private i As Integer, ii As Integer
Private Red As Double, Green As Double, Blue As Double
Private X1 As Double, Y1 As Double, X2 As Double, Y2 As Double, Dikey As Double, Yatay As Double
Private Boyu As Double 'RowHight
Private Eni As Double 'ColumnWidth
Private Durum As Double
Private Const ÇerçeveRengi As Variant = "&HC000C0" 'Control color...
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] UserForm Painting By SetPixel Function "
    Application.Visible = False
    Call EkranDüzenle
End Sub
Private Sub UserForm_Activate()

    On Error Resume Next
    If Durum = 0 Then
        Durum = 1
        With Me
            .StartUpPosition = 2
            .Top = Me.Top - Me.Height / 2
        End With
        Call KoordinatTespiti
    End If
End Sub
Private Sub UserForm_Terminate()

    On Error Resume Next
    Application.Visible = True
    UserForm2.Hide
    End
End Sub
Private Sub CommandButton1_Click()

    On Error Resume Next
    Alan1 = GetDC(FindWindow(vbNullString, Me.Caption))
    Alan2 = GetDC(FindWindow(vbNullString, UserForm2.Caption))
    UserForm2.Caption = "[PBİD®] Canvas UserForm [GetDC: " & Alan2 & "]"
    For i = 0 To (Image2.Width / 0.748)
        For ii = 0 To (Image2.Height / 0.748)
            Yatay = i + X1
            Dikey = ii + Y1
            Nokta1 = GetPixel(Alan1, Yatay, Dikey)
            If Nokta1 <> -1 Then
                HexKod1 = "&H" & VBA.Hex(Nokta1)
                Red = VBA.Int(Nokta1 Mod 256)
                Green = VBA.Int((Nokta1 Mod 65536) / 256)
                Blue = VBA.Int(Nokta1 / 65536)
                CommandButton1.BackColor = VBA.RGB(Red, Green, Blue)
                SetPixel Alan2, Yatay, Dikey, Nokta1 'UserForm2 painting
            End If
            Label16.Caption = ii
            Label20.Caption = HexKod1
            Label22.Caption = VBA.RGB(Red, Green, Blue)
            Label24.Caption = Red
            Label26.Caption = Green
            Label28.Caption = Blue
            ProgressBar1.Value = 100 * (ii / (Image2.Height / 0.748))
            Label17.Caption = VBA.Format((ii / (Image2.Height / 0.748)), "0.00%")
            DoEvents
        Next ii
        Label14.Caption = i
        ProgressBar2.Value = 100 * (i / (Image2.Width / 0.748))
        Label18.Caption = VBA.Format((i / (Image2.Width / 0.748)), "0.00%")
        DoEvents
    Next i
    CommandButton1.BackColor = VBA.RGB(255, 255, 255)
    Label16.Caption = 0
    Label18.Caption = 0
    Label20.Caption = 0
    Label22.Caption = 0
    Label24.Caption = 0
End Sub
Private Sub KoordinatTespiti()

    On Error Resume Next
    Label6.Caption = 0: Label8.Caption = 0: Label10.Caption = 0: Label12.Caption = 0: Label14.Caption = 0: Label16.Caption = 0
    X1 = 32720: X2 = 0: Y1 = 32720: Y2 = 0
    Alan1 = GetDC(FindWindow(vbNullString, Me.Caption))
    For i = 1 To Me.Width
        For ii = 1 To Me.Height
            Yatay = i
            Dikey = ii
            Nokta1 = GetPixel(Alan1, Yatay, Dikey)
            If Nokta1 <> -1 Then
                HexKod1 = "&H" & VBA.Hex(Nokta1)
                If HexKod1 = ÇerçeveRengi Then
                    If Yatay <= X1 Then X1 = Yatay: If Yatay >= X2 Then X2 = Yatay
                    If Dikey <= Y1 Then Y1 = Dikey: If Dikey >= Y2 Then Y2 = Dikey
                End If
            End If
            ProgressBar1.Value = 100 * (ii / Me.Height)
            Label16.Caption = ii
            Label17.Caption = VBA.Format((ii / Me.Height), "0.00%")
            DoEvents
        Next ii
        ProgressBar2.Value = 100 * (i / Me.Width)
        Label14.Caption = i
        Label18.Caption = VBA.Format((i / Me.Width), "0.00%")
        DoEvents
    Next i
    Label6.Caption = X1: Label8.Caption = X2: Label10.Caption = Y1: Label12.Caption = Y2
End Sub
Private Sub EkranDüzenle()

    On Error Resume Next
    With Me
        .Height = 252
        .Width = 424
        .Picture = Resim(URL2)
        .PictureAlignment = fmPictureAlignmentCenter
        .PictureSizeMode = fmPictureSizeModeStretch
        .PictureTiling = False
    End With
    With Image1
        .Left = 6
        .Top = 6
        .Height = 24
        .Width = 24
        .BackStyle = fmBackStyleTransparent
        .BorderColor = &H80000002
        .BorderStyle = fmBorderStyleSingle
        .Picture = Resim(URL1)
        .PictureAlignment = fmPictureAlignmentCenter
        .PictureSizeMode = fmPictureSizeModeClip
        .PictureTiling = False
    End With
    With Label1
        .Caption = "Mustafa ULUSARAÇ"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleNone
        .Font.Bold = True
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 36
        .Top = 6
        .Height = 12
        .Width = 228
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label2
        .Caption = "
01ulusarac@superonline.com"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleNone
        .Font.Bold = True
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 36
        .Top = 18
        .Height = 12
        .Width = 228
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label3
        .Caption = "Painting Data"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 36
        .Height = 12
        .Width = 174
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Image2
        .AutoSize = False
        .Left = 186
        .Top = 54
        .Height = 168
        .Width = 228
        .Picture = Resim(URL3)
        .PictureAlignment = fmPictureAlignmentCenter
        .PictureSizeMode = fmPictureSizeModeStretch
        .PictureTiling = False
        .BackStyle = fmBackStyleOpaque
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = ÇerçeveRengi
        .SpecialEffect = fmSpecialEffectFlat
    End With
    With Label4
        .Caption = "Picture"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 186
        .Top = 36
        .Height = 12
        .Width = 228
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label5
        .Caption = "X1"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 54
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label6
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 36
        .Top = 54
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label7
        .Caption = "X2"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 72
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label8
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 36
        .Top = 72
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label9
        .Caption = "Y1"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 96
        .Top = 54
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label10
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 126
        .Top = 54
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label11
        .Caption = "Y2"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 96
        .Top = 72
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label12
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 126
        .Top = 72
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label13
        .Caption = "X"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 90
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label14
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 36
        .Top = 90
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label15
        .Caption = "Y"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 96
        .Top = 90
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label16
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 126
        .Top = 90
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With ProgressBar1
        .Left = 6
        .Top = 108
        .Height = 12
        .Width = 114
        .Appearance = ccFlat
        .BorderStyle = ccFixedSingle
        .Min = 0
        .Max = 100
    End With
    With Label17
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 126
        .Top = 108
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With ProgressBar2
        .Left = 6
        .Top = 126
        .Height = 12
        .Width = 114
        .Appearance = ccFlat
        .BorderStyle = ccFixedSingle
        .Min = 0
        .Max = 100
    End With
    With Label18
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 126
        .Top = 126
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With CommandButton1
        .Left = 6
        .Top = 144
        .Height = 24
        .Width = 174
        .Caption = "Make a Painting"
        .BackStyle = fmBackStyleOpaque
        .BackColor = vbWhite
    End With
    With Label19
        .Caption = " HexaDecimal"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 174
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label20
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 66
        .Top = 174
        .Height = 12
        .Width = 114
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label21
        .Caption = " Point RGB"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 192
        .Height = 12
        .Width = 54
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label22
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 66
        .Top = 192
        .Height = 12
        .Width = 114
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label23
        .Caption = " Red"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 6
        .Top = 210
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label24
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 36
        .Top = 210
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label25
        .Caption = "Green"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 66
        .Top = 210
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label26
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 96
        .Top = 210
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
    With Label27
        .Caption = "Blue"
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlack
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 126
        .Top = 210
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignLeft
    End With
    With Label28
        .Caption = ""
        .AutoSize = False
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
        .Font.Bold = False
        .ForeColor = vbBlue
        .SpecialEffect = fmSpecialEffectFlat
        .Left = 156
        .Top = 210
        .Height = 12
        .Width = 24
        .WordWrap = False
        .TextAlign = fmTextAlignCenter
    End With
End Sub

'UserForm2

Option Explicit
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] Canvas UserForm [GetDC: " & Alan2 & "]"
    Call EkranDüzenle
End Sub
Private Sub UserForm_Activate()

    On Error Resume Next
    With Me
        .StartUpPosition = 2
        .Top = UserForm1.Top + UserForm1.Height: .Left = UserForm1.Left
    End With
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    On Error Resume Next
    If Button = 1 Then SetPixel GetDC(FindWindow(vbNullString, Me.Caption)), X / 0.748, Y / 0.748, vbRed 'Manuel painting...
End Sub
Private Sub EkranDüzenle()

    On Error Resume Next
    With Me
        .Height = 252
        .Width = 424
        .Picture = Resim(URL2)
        .PictureAlignment = fmPictureAlignmentCenter
        .PictureSizeMode = fmPictureSizeModeStretch
        .PictureTiling = False
    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}" 'It may take a few seconds, please wait.
Public Const URL1 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 Logo]
Public Const URL2 As String = "
http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Kılavuzu [Bant]
Public Const URL3 As String = "
http://www.thetechherald.com/media/images/200918/windows_xp_logo_10.jpg" '[XP Logo]
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 Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Nokta1, HexKod1, Alan1, Alan2
Sub FormAç()
    On Error Resume Next
    UserForm1.Show 0
    UserForm2.Show 0
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 ReferenceList() 'Mevcut
    'On Error Resume Next
    'Dim Eleman, i
    'i = 1
    'For Each Eleman In ThisWorkbook.VBProject.References
        'Cells(i, 1) = "Description: "
        'Cells(i, 2) = Eleman.Description
        'Cells(i, 3) = "FullPath: "
        'Cells(i, 4) = Eleman.FullPath
        'i = i + 1
    'Next Eleman
'End Sub
 

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