Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

19 Mayıs 2010 Çarşamba

xlSurface ChartType in UserForm



'UserForm1

'A) Tools\Macro\Security Otions [Picture: 1]


'B) 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

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

'Image1, Label1, Label2
'Label3, ComboBox1, Label4, ComboBox2, Label5, ComboBox3
'CommandButton1

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Renk As Double, ApsisHesap As Double, OrdinatHesap As Double, Çerçeve As Double
Private Sabit1 As Double, Sabit2 As Double, KolonAdet As Double, Sonuç As Double, Red As Double, Green As Double, Blue As Double
Private x As Single, y As Single, i As Single, ii As Single, iii As Single
Private x1 As Double, y1 As Double, x2 As Double, y2 As Double
Private Alan As Long, Grafik As Long
Private GrafikAdresi As String
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] xlSurface ChartType in UserForm"
Application.Visible = True' False
Application.VBE.MainWindow.Visible = False
Application.DisplayAlerts = False
Call EkranDüzenle
Alan = GetDC(FindWindow(vbNullString, Me.Caption))

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error GoTo Hata
Application.DisplayAlerts = False
Sheets("ChartDataPage").Select
ActiveWindow.SelectedSheets.Delete
Hata:

End Sub
Private Sub CommandButton1_Click()

On Error Resume Next
Me.Repaint
Call GrafikDüzenle
Call GrafikBul
ActiveChart.ShowWindow = False

End Sub
Private Sub GrafikBul()

On Error Resume Next
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Select
ActiveChart.ShowWindow = True
ActiveChart.Deselect
Grafik = GetDC(FindWindow(vbNullString, ActiveWindow.Caption))
Application.ActiveWindow.Left = 24
Application.ActiveWindow.Top = 24
If Grafik > 0 Then

With CommandButton1

.Caption = "Please Again [Chart to Prepare]"
.ForeColor = vbBlack

End With
Call GrafikGetir

Else

With CommandButton1

.Caption = "Please Again [Chart to Prepare]"
.ForeColor = vbRed

End With

End If

End Sub
Private Sub GrafikGetir()

On Error Resume Next
Çerçeve = (ActiveWindow.Width - ActiveWindow.UsableWidth) / 0.748
x1 = ActiveWindow.Left / 0.748 + Çerçeve
y1 = (ActiveWindow.Top + (ActiveWindow.Height - ActiveWindow.UsableHeight)) / 0.748 + (24 * 3) / 0.748 - Çerçeve
x2 = (ActiveWindow.Left + ActiveWindow.UsableWidth) / 0.748
y2 = y1 + ActiveWindow.UsableHeight / 0.748 - Çerçeve
For x = x1 To x2

For y = y1 To y2

i = x - x1 + 6 / 0.748
ii = y - y1 + 36 / 0.748
Renk = GetPixel(Grafik, x, y)
Red = VBA.Int(Renk Mod 256)
Green = VBA.Int((Renk Mod 65536) / 256)
Blue = VBA.Int(Renk / 65536)
'SetPixel Alan, i, ii, Renk
SetPixel Alan, i, ii, VBA.RGB(Red, Green, Blue)
DoEvents

Next y

Next x

End Sub
Sub GrafikDüzenle()

On Error GoTo Devam
Application.DisplayAlerts = False
Sheets("ChartDataPage").Select
ActiveWindow.SelectedSheets.Delete
Devam:
On Error Resume Next
ThisWorkbook.Worksheets.Add Sheets(1)
ActiveSheet.Name = "ChartDataPage"
Sheets("ChartDataPage").Select
Cells.Select
Selection.Delete Shift:=xlUp
KolonAdet = ComboBox1.Value
Sabit1 = ComboBox2.Value
Sabit2 = ComboBox3.Value
ReDim Bellek(1 To KolonAdet, 1 To KolonAdet)
For i = 1 To (KolonAdet - 1)

Bellek(1, i + 1) = i - (KolonAdet / 2)

Next i
For ii = 1 To (KolonAdet - 1)

Bellek(ii + 1, 1) = ii - (KolonAdet / 2)

Next ii
On Error Resume Next
For i = 1 To (KolonAdet - 1)

For ii = 1 To (KolonAdet - 1)

x = Bellek(1, i + 1)
y = Bellek(ii + 1, 1)
If x = 0 Then

ApsisHesap = 0

Else

ApsisHesap = x ^ Sabit1

End If
If y = 0 Then

OrdinatHesap = 0

Else

OrdinatHesap = y ^ Sabit2

End If
Sonuç = VBA.Sqr(ApsisHesap + OrdinatHesap)
If VBA.Err.Number <> 0 Then

Bellek(i + 1, ii + 1) = 0
VBA.Err.Number = 0

Else

Bellek(i + 1, ii + 1) = Sonuç

End If

Next ii

Next i
Sheets("ChartDataPage").Range(Cells(1, 1), Cells(KolonAdet, KolonAdet)) = Bellek
Sheets("ChartDataPage").Range(Cells(1, 1), Cells(KolonAdet, KolonAdet)).Select
GrafikAdresi = ActiveWindow.RangeSelection.Address
Charts.Add
With ActiveChart

.ChartType = xlSurface
.SetSourceData Source:=Sheets("ChartDataPage").Range(GrafikAdresi), PlotBy:=xlRows
.Location Where:=xlLocationAsObject, Name:="ChartDataPage"
.HasAxis(xlCategory) = False
.HasAxis(xlSeries) = False
.HasAxis(xlValue) = False
.Axes(xlCategory).CategoryType = xlAutomatic
With .Axes(xlCategory)

.HasMajorGridlines = False
.HasMinorGridlines = False

End With
With .Axes(xlSeries)

.HasMajorGridlines = False
.HasMinorGridlines = False

End With
With .Axes(xlValue)

.HasMajorGridlines = False
.HasMinorGridlines = False

End With
.WallsAndGridlines2D = False
.HasLegend = False

End With
With Selection.Border

.ColorIndex = 3
.Weight = 2
.LineStyle = 1

End With
Selection.Interior.ColorIndex = xlAutomatic
Sheets("ChartDataPage").DrawingObjects("Chart 1").RoundedCorners = False
Sheets("ChartDataPage").DrawingObjects("Chart 1").Shadow = False
With ActiveChart

.Elevation = 15
.Perspective = 30
.Rotation = 20
.RightAngleAxes = False
.HeightPercent = 100
.AutoScaling = True

End With
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.Shapes("Chart 1").Left = 0
ActiveSheet.Shapes("Chart 1").Top = 0
ActiveSheet.Shapes("Chart 1").Height = 324
ActiveSheet.Shapes("Chart 1").Width = 324
ActiveChart.Walls.Select
With Selection.Border

.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous

End With
Selection.Fill.UserPicture PictureFile:="C:\Documents and Settings\All Users\Belgeler\Resimlerim\Örnek Resimler\Mavi tepeler.jpg", PictureFormat:=xlStretch 'Blue Hill
Selection.Fill.Visible = True
ActiveChart.Floor.Select
With Selection.Border

.Weight = xlHairline
.LineStyle = xlAutomatic

End With
Selection.Fill.UserPicture PictureFile:="C:\Documents and Settings\All Users\Belgeler\Resimlerim\Örnek Resimler\Kış.jpg", PictureFormat:=xlStretch 'Winter
Selection.Fill.Visible = True
ActiveChart.Walls.Select
With Selection.Border

.ColorIndex = 32
.Weight = xlThin
.LineStyle = xlContinuous

End With
ActiveChart.Floor.Select
With Selection.Border

.ColorIndex = 11
.Weight = xlHairline
.LineStyle = xlContinuous

End With
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Legend.Select
Selection.Delete
ActiveChart.Axes(xlValue).MajorGridlines.Select
With Selection.Border

.ColorIndex = 2
.Weight = xlHairline
.LineStyle = xlContinuous

End With
ActiveChart.Axes(xlSeries).Select
With Selection.Border

.ColorIndex = 5
.Weight = xlHairline
.LineStyle = xlContinuous

End With
With Selection

.MajorTickMark = xlOutside
.MinorTickMark = xlNone
.TickLabelPosition = xlLow

End With
ActiveChart.Axes(xlCategory).Select
With Selection.Border

.ColorIndex = 32
.Weight = xlHairline
.LineStyle = xlContinuous

End With
With Selection

.MajorTickMark = xlOutside
.MinorTickMark = xlNone
.TickLabelPosition = xlLow

End With
Range("A1").Select

End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me

.BackColor = vbWhite
.Height = 452
.Width = 348
'.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\VectorBackround.jpg")
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1

.Left = 6
.Top = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
'.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\PBİD.ico")
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False

End With
With Label1

.Caption = "Mustafa ULUSARAÇ"
.Left = 36
.Top = 6
.Height = 12
.Width = 300
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft
.ForeColor = vbBlue
.Font.Bold = True
.BorderStyle = fmBorderStyleNone

End With
With Label2

.Caption = "01ulusarac@superonline.com"
.Left = 36
.Top = 18
.Height = 12
.Width = 300
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft
.ForeColor = vbBlue
.Font.Bold = True
.BorderStyle = fmBorderStyleNone

End With
With Label3

.Caption = " Kolon Sayısı"
.Left = 6
.Top = 372
.Height = 18
.Width = 48
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignLeft
.ForeColor = vbBlack
.Font.Bold = False
.BorderStyle = fmBorderStyleNone

End With
With ComboBox1

.Left = 54
.Top = 372
.Height = 18
.Width = 54
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = vbBlack
.Font.Bold = False
For i = 4 To 256 Step 2

.AddItem i

Next i
.Value = 24
.ListWidth = 54
.ColumnWidths = 54

End With
With Label4

.Caption = " Apsis º"
.Left = 114
.Top = 372
.Height = 18
.Width = 54
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignLeft
.ForeColor = vbBlack
.Font.Bold = False
.BorderStyle = fmBorderStyleNone

End With
With ComboBox2

.Left = 168
.Top = 372
.Height = 18
.Width = 54
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = vbBlack
.Font.Bold = False
For i = -12 To 12

.AddItem i

Next i
.Value = 4
.ListWidth = 54
.ColumnWidths = 54

End With
With Label5

.Caption = " Ordinat º"
.Left = 228
.Top = 372
.Height = 18
.Width = 54
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignLeft
.ForeColor = vbBlack
.Font.Bold = False
.BorderStyle = fmBorderStyleNone

End With
With ComboBox3

.Left = 282
.Top = 372
.Height = 18
.Width = 54
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = vbBlack
.Font.Bold = False
For i = -12 To 12

.AddItem i

Next i
.Value = 4
.ListWidth = 54
.ColumnWidths = 54

End With
With CommandButton1

.Left = 6
.Top = 396
.Height = 24
.Width = 330
.BackStyle = fmBackStyleTransparent
.Caption = "Chart to Prepare"
.Font.Bold = True
.ForeColor = vbBlack

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}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" '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]
Sub FormAç()

On Error Resume Next
UserForm1.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

10 Mayıs 2010 Pazartesi

Worksheet And Spreadsheet Painting By GetPixel 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 Office Web Components 11.0, FullPath: C:\Program Files\Common Files\Microsoft Shared\Web Components\11\OWC11.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, Spreadsheet1
'Label5, Label6, Label7, Label8
'Label9, Label10, Label11, Label12
'Label13, Label14, Label15, Label16
'ProgressBar1, Label17
'ProgressBar2, Label18
'ComboBox1, ComboBox2
'CommandButton1
'Label19, Label20
'Label21, Label22
'Label23, Label24, Label25, Label26, Label27, Label28
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Private 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
Private IPic(15) As Byte
Private Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'It may take a few seconds, please wait.

Private 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]
Private Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Kılavuzu [Bant]
Private Const URL3 As String = "http://thebsreport.files.wordpress.com/2009/05/mountain-lion.jpg" '[Puma]Dim i As Integer, ii As Integer
Private Eleman As Worksheet
Private Nokta, HexKod, Alan
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 Const ÇerçeveRengi As Variant = "&HC000C0" 'Control color...
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Worksheet And Spreadsheet Painting By GetPixel Function "
Call EkranDüzenle
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Call KoordinatTespiti
Me.StartUpPosition = 2
End Sub
Private Sub ComboBox1_Change()
On Error Resume Next
Select Case ComboBox1.ListIndex
Case 0: Eni = 0.08: Boyu = 0.75
Case 1: Eni = 0.17: Boyu = 1.5
Case 2: Eni = 0.25: Boyu = 2.25
Case 3: Eni = 0.33: Boyu = 3
Case 4: Eni = 0.42: Boyu = 4
Case 5: Eni = 0.5: Boyu = 4.75
Case 6: Eni = 0.58: Boyu = 5.5
End Select
Call SayfaDüzenle
End Sub
Private Sub ComboBox2_Change()
On Error Resume Next
Call SayfaDüzenle
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
ThisWorkbook.Sheets("Resim").Select
Alan = GetDC(FindWindow(vbNullString, Me.Caption))
For i = X1 To X2
For ii = Y1 To Y2
Yatay = i
Dikey = ii
Nokta = GetPixel(Alan, Yatay, Dikey)
If Nokta <> -1 Then
HexKod = "&H" & VBA.Hex(Nokta)
Red = VBA.Int(Nokta Mod 256)
Green = VBA.Int((Nokta Mod 65536) / 256)
Blue = VBA.Int(Nokta / 65536)
CommandButton1.BackColor = VBA.RGB(Red, Green, Blue)
If i > 256 Then
If ComboBox2.ListIndex = 1 Then Spreadsheet1.ActiveSheet.Cells(Dikey - Y1 + 1, Yatay - X1 + 1).Interior.Color = VBA.RGB(Red, Green, Blue)
Else
If ComboBox2.ListIndex = 0 Then Sheets("Resim").Cells(Dikey - Y1 + 1, Yatay - X1 + 1).Interior.Color = VBA.RGB(Red, Green, Blue)
If ComboBox2.ListIndex = 1 Then Spreadsheet1.ActiveSheet.Cells(Dikey - Y1 + 1, Yatay - X1 + 1).Interior.Color = VBA.RGB(Red, Green, Blue)
End If
End If
Label16.Caption = ii
Label20.Caption = HexKod
Label22.Caption = VBA.RGB(Red, Green, Blue)
Label24.Caption = Red
Label26.Caption = Green
Label28.Caption = Blue
ProgressBar1.Value = 100 * (ii / Y2)
Label17.Caption = VBA.Format((ii / Y2), "0.00%")
DoEvents
Next ii
Label14.Caption = i
ProgressBar2.Value = 100 * (i / X2)
Label18.Caption = VBA.Format((i / X2), "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
'Alan = GetDC(FindWindow(vbNullString, Me.Caption))
'For i = 1 To Me.Width
'For ii = 1 To Me.Height
'Yatay = i
'Dikey = ii
'Nokta = GetPixel(Alan, Yatay, Dikey)
'If Nokta <> -1 Then
'HexKod = "&H" & VBA.Hex(Nokta)
'If HexKod = Ç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
X1 = VBA.Round(Image2.Left / 0.748, 0):Y1 = VBA.Round(Image2.Top / 0.748, 0):X2 = VBA.Round((Image2.Left + Image2.Width) / 0.748, 0):Y2 = VBA.Round((Image2.Top + Image2.Height) / 0.748, 0)
Label6.Caption = X1: Label8.Caption = X2: Label10.Caption = Y1: Label12.Caption = Y2
End Sub
Private Sub SayfaDüzenle()
On Error Resume Next
For Each Eleman In ThisWorkbook.Worksheets
If Eleman.Name = "Resim" Then GoTo Devam1
Next Eleman
ThisWorkbook.Worksheets.Add Sheets(1)
ActiveSheet.Name = "Resim"
Devam1:
ThisWorkbook.Sheets("Resim").Select
Cells.Select
Selection.Delete Shift:=xlUp
Selection.ColumnWidth = Eni
Selection.RowHeight = Boyu
With ActiveWindow
.DisplayHeadings = False
.DisplayOutline = False
.DisplayZeros = False
.DisplayGridlines = False
End With
[A1].Select
With Spreadsheet1
.Sheets(1).Cells.Select
Selection.Delete Shift:=xlUp
.Sheets(1).Cells.ColumnWidth = Eni
.Sheets(1).Cells.RowHeight = Boyu
.ActiveWindow.DisplayGridlines = False
.[A1].Select
End With
End Sub
Private 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
Private Sub EkranDüzenle()
With Me
.Height = 510
.Width = 647
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.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 = "Picture"
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Font.Bold = False
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectFlat
.Left = 6
.Top = 42
.Height = 12
.Width = 174
.WordWrap = False
.TextAlign = fmTextAlignCenter
End With
With Image2
.AutoSize = False
.Left = 6
.Top = 54
.Height = 228
.Width = 174
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleSingle
.BorderColor = ÇerçeveRengi
.SpecialEffect = fmSpecialEffectFlat
End With
With Label4
.Caption = "Spreadsheet1"
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Font.Bold = False
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectFlat
.Left = 186
.Top = 42
.Height = 12
.Width = 450
.WordWrap = False
.TextAlign = fmTextAlignCenter
End With
With Spreadsheet1
.DisplayDesignTimeUI = False
.DisplayOfficeLogo = False
.DisplayPropertyToolbox = False
.DisplayTitleBar = False
.DisplayTitleBar = False
.DisplayToolbar = False
With .ActiveWindow
.DisplayGridlines = False
.DisplayColumnHeadings = False
.DisplayRowHeadings = False
.EnableResize = False
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
End With
.Left = 186
.Top = 54
.Height = 426
.Width = 450
End With
With Label5
.Caption = "X1"
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Font.Bold = False
.ForeColor = vbBlack
.SpecialEffect = fmSpecialEffectFlat
.Left = 6
.Top = 288
.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 = 288
.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 = 306
.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 = 306
.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 = 288
.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 = 288
.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 = 306
.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 = 306
.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 = 324
.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 = 324
.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 = 324
.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 = 324
.Height = 12
.Width = 54
.WordWrap = False
.TextAlign = fmTextAlignCenter
End With
With ProgressBar1
.Left = 6
.Top = 342
.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 = 342
.Height = 12
.Width = 54
.WordWrap = False
.TextAlign = fmTextAlignCenter
End With
With ProgressBar2
.Left = 6
.Top = 360
.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 = 360
.Height = 12
.Width = 54
.WordWrap = False
.TextAlign = fmTextAlignCenter
End With
With ComboBox1
.Left = 6
.Top = 378
.Height = 18
.Width = 114
.AutoSize = False
.BackColor = vbWhite
.BackStyle = fmBackStyleOpaque
.BorderColor = vbBlue
.BorderStyle = fmBorderStyleSingle
.Font.Bold = False
.Text = "Ölçek [Scale]"
.SpecialEffect = fmSpecialEffectFlat
.AddItem "Hight:0,750-Width:0,080"
.AddItem "Hight:1,500-Width:0,170"
.AddItem "Hight:2,250-Width:0,250"
.AddItem "Hight:3,000-Width:0,330"
.AddItem "Hight:4,000-Width:0,420"
.AddItem "Hight:4,750-Width:0,500"
.AddItem "Hight:5,500-Width:0,580"
.ListIndex = 0
End With
With ComboBox2
.Left = 126
.Top = 378
.Height = 18
.Width = 54
.AutoSize = False
.BackColor = vbWhite
.BackStyle = fmBackStyleOpaque
.BorderColor = vbBlue
.BorderStyle = fmBorderStyleSingle
.Font.Bold = False
.Text = "Sayfa [Sheet]"
.SpecialEffect = fmSpecialEffectFlat
.AddItem "WorkSheet"
.AddItem "Spreadsheet"
.ListIndex = 0
End With
With CommandButton1
.Left = 6
.Top = 402
.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 = 432
.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 = 432
.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 = 450
.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 = 450
.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 = 468
.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 = 468
.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 = 468
.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 = 468
.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 = 468
.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 = 468
.Height = 12
.Width = 24
.WordWrap = False
.TextAlign = fmTextAlignCenter
End With
End Sub 
'Module1

Option Explicit
Sub FormAç()
On Error Resume Next
Application.DisplayAlerts = False
UserForm1.Show 0
End Sub
'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



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

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