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

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul