Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Mart 2004 Cumartesi

UserForm AnimateWindow 02





'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Forms 2.0 Object Library
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'Microsoft Internet Controls
'B) UserForm1 E Eklenen Araçlar (Add Tools)
'Frame1
'Frame1\Image1, Label1, Label2
'WebBrowser1, TextBox1
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub SetWindowPos Lib "user32" (ByVal Pencere As Long, ByVal PencereInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function GetWindowRect Lib "user32" (ByVal Pencere As Long, lpRect As Dörtgen) As Long
Private Declare Function AnimateWindow Lib "user32" (ByVal Pencere As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Type Koordinat

X As Long
Y As Long
End Type
Private Type Dörtgen

Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Boyut As Dörtgen
Private Const MEkran = 0
Private Const MSistem = 1
Private Const EPozisyon& = &H1
Private Pencere As Long
Private AEn As Integer, ABoy As Integer, EEn As Integer, EBoy As Integer, ESol As Integer, EÜst As Integer
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD ®] UserForm AnimateWindow 02"
Call EkranDüzenle
Call NetAç
Call HtmlKod
End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 254
.Width = 528
.BackColor = &H8000000F
With Frame1
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
End With
With WebBrowser1
.Left = 6
.Top = 42
.Height = 156
.Width = 510
.Navigate "About:Blank"
Do While .Busy
DoEvents
Loop
DoEvents
End With
With TextBox1
.Left = 6
.Top = 204
.Height = 18
.Width = 510
.Text = "[PBİD®] UserForm Animate Mustafa ULUSARAÇ 01ulusarac@superonline.com"
.Font.Bold = True
.ForeColor = vbBlue
End With
End With
End Sub
Sub NetAç()
'NetShow

On Error Resume Next
With WebBrowser1
.Document.Open
End With
AEn = GetSystemMetrics32(MEkran)
ABoy = GetSystemMetrics32(MSistem)
Pencere = FindWindow(vbNullString, Me.Caption)
GetWindowRect Pencere, Boyut
EEn = VBA.Abs(Boyut.Right - Boyut.Left)
EBoy = VBA.Abs(Boyut.Top - Boyut.Bottom)
ESol = (AEn - EEn) / 2
EÜst = (ABoy - EBoy) / 2
SetWindowPos Pencere, 0&, ESol, EÜst, 0&, 0&, EPozisyon
AnimateWindow Pencere, 800, &H10 Or &H20000
Me.Repaint
End Sub
Sub HtmlKod() 'HtmlCode

On Error Resume Next
'HtmlCode is in the Code Picture(1)
End Sub

'Module1

Option Explicit
Sub FormAç()

On Error Resume Next
Load UserForm1
End Sub

10 Mart 2004 Çarşamba

UserForm AnimateWindow 01





'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Forms 2.0 Object Library
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'B) UserForm1 e Eklenen Araçlar (Add Tools)
'Frame1
'Frame1\Image1, Label1, Label2
'Label3, Label4, Label5, TextBox1, textBox2, TextBox2, CommandButton1
Option Explicit
Dim Pencere As Long, dwTime As Long, dwFlag1 As Long, dwFlag2 As Long
Dim YeniUserForm As UserForm2
Dim Kontrol As Long
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD ®] UserForm AnimateWindow"
Call EkranDüzenle
End Sub
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error Resume Next
If IsNumeric(TextBox1.Value) = False Then TextBox1.Value = 800
End Sub
Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error Resume Next
If Not VBA.Left(TextBox2.Value, 2) = "&H" Then
With TextBox2
.SelStart = 0
.SelLength = 2
.SelText = "&H"
End With
End If
End Sub
Private Sub TextBox3_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error Resume Next
If Not VBA.Left(TextBox3.Value, 2) = "&H" Then
With TextBox3
.SelStart = 0
.SelLength = 2
.SelText = "&H"
End With
End If
End Sub
Private Sub CommandButton1_Click()

On Error Resume Next
Me.Hide
Set YeniUserForm = New UserForm2
With YeniUserForm
.Left = Me.Left + 6
.Top = Me.Top + 114
.Width = Me.Width - 12
.Height = Me.Height - 124
End With
Pencere = FindWindow(vbNullString, YeniUserForm.Caption)
dwTime = TextBox1.Value
dwFlag1 = TextBox2.Value
dwFlag2 = TextBox3.Value
Kontrol = AnimateWindow(Pencere, dwTime, dwFlag1 Or dwFlag2)
If Kontrol = 0 Then Me.Show
YeniUserForm.Repaint
Exit Sub
End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 282
.Width = 306
With Frame1
.Top = -2
.Left = -2
.Height = 36
.Width = Me.Width + 12
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
End With
With Label3
.Caption = "dwTime"
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 36
.Height = 12
.Width = 96
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With TextBox1
.Value = 800
.SpecialEffect = fmSpecialEffectEtched
.Left = 6
.Top = 48
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = vbBlue
.TextAlign = fmTextAlignCenter
End With
With Label4
.Caption = "dwFlag1"
.SpecialEffect = fmSpecialEffectEtched
.Left = 102
.Top = 36
.Height = 12
.Width = 96
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With TextBox2
.Value = "&H4"
.SpecialEffect = fmSpecialEffectEtched
.Left = 102
.Top = 48
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = vbBlue
.TextAlign = fmTextAlignCenter
End With
With Label5
.Caption = "dwFlag2"
.SpecialEffect = fmSpecialEffectEtched
.Left = 198
.Top = 36
.Height = 12
.Width = 96
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With TextBox3
.Value = "&H60000"
.SpecialEffect = fmSpecialEffectEtched
.Left = 198
.Top = 48
.Height = 18
.Width = 96
.Font.Bold = True
.ForeColor = vbBlue
.TextAlign = fmTextAlignCenter
End With
With CommandButton1
.Left = 6
.Top = 72
.Height = 18
.Width = 288
.Caption = "UserForm2 Window Animate"
End With
End With
End Sub

'UserForm2

Option Explicit
Private Sub UserForm_Activate()

On Error Resume Next
Me.Caption = "UserForm2 Animated Flags= " & UserForm1.TextBox2.Value & "-" & UserForm1.TextBox3.Value
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Cancel = True
AnimateWindow FindWindow(vbNullString, Me.Caption), 800, &H80000 Or &H10000
UserForm1.Show
End Sub

'Module1

Option Explicit
Public Declare Function AnimateWindow Lib "user32" (ByVal hWnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub ÖrnekAnimateWindow()
'AnimateWindow Example

On Error Resume Next
UserForm1.Show 0
End Sub

1 Mart 2004 Pazartesi

Prepare a chart on the UserForm object OWC11.ChartSpace.11



'UserForm1
'A) Windows XP® Office 2003® Normal Reference 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'a Eklenen Araçlar (Add Tools)
'Image1, Label1, Label2
'C) Chart Backround Picture
Option Explicit
Dim i As Integer
Dim Grafik As Object
Dim GrafikCategories(1 To 36)
Dim GrafikValues(1 To 36)
Dim ÇerçeveDüzenleme As New Class1
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD ®] Prepare a chart on the UserForm object OWC11.ChartSpace.11"
Call EkranDüzenle
Call GrafikHazırla
Application.Visible = False
Application.VBE.MainWindow.Visible = False
Set ÇerçeveDüzenleme.LogoYerleştir = Me
Set ÇerçeveDüzenleme.Form1 = Me
End Sub
Private Sub UserForm_Activate()

On Error Resume Next
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
End Sub
Private Sub UserForm_Resize()

On Error Resume Next
With Me
.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2
End With
Call GrafikDüzenle
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Call Kapat
End
End Sub
Sub Kapat()

Set ÇerçeveDüzenleme.FormYokol = Me
Unload Me
Application.Visible = True
Application.VBE.MainWindow.Visible = True
ActiveWorkbook.Save
'Application.Quit
End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 426
.Width = 558
.BackColor = vbWhite
.Picture = LoadPicture("C:\Documents and Settings\ULUSARAÇ\Belgelerim\Mustafa ULUSARAÇ\ExcelÖrnekler\VectorBackround.jpg")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
With Image1
.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = LoadPicture("C:\Documents and Settings\ULUSARAÇ\Belgelerim\Mustafa ULUSARAÇ\ExcelÖrnekler\PBİD.ico")
End With
With Label1
.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
With Label2
.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000
End With
Set Grafik = Me.Controls.Add("OWC11.ChartSpace.11")
Call GrafikDüzenle
End With
End Sub
Sub GrafikDüzenle()

On Error Resume Next
With Grafik
.Left = 0
.Top = 36
.Height = Me.InsideHeight - 36
.Width = Me.InsideWidth
End With
DoEvents
End Sub
Sub GrafikHazırla()

On Error Resume Next
For i = 1 To 36
GrafikCategories(i) = VBA.DateSerial(2000, i, 1)
GrafikValues(i) = VBA.Rnd
Next i
'Set Grafik = Me.Controls.Add("OWC11.ChartSpace.11")
With Grafik
.Charts.Add 0
With .Charts(0)
.Type = chChartTypeColumnClustered
With .Axes(0)
.Font.Color = &H4000&
.Font.Size = 8
End With
.HasAutoAspectRatio = True
.HasAutoChartDepth = True
.HasLegend = True
.HasTitle = True
.Interior.SetTwoColorGradient chGradientDiagonalDown, chGradientVariantCenter, vbGreen, vbWhite
.Legend.Position = chLegendPositionBottom
With .PlotArea
With .Border
.Color = vbWhite
.Weight = xlThin
.DashStyle = chLineSolid
End With
.Interior.SetTextured "C:\Documents and Settings\ULUSARAÇ\Belgelerim\Mustafa ULUSARAÇ\ExcelÖrnekler\VistaWallPaper01.jpg", chStretch, 1, chAllFaces
End With
.SeriesCollection.Add 0
With .SeriesCollection(0)
With .Border
.Color = vbWhite
.Weight = xlThin
End With
.Caption = "AxS"
.Interior.SetTextured msoTextureWaterDroplets
.SetData chDimCategories, chDataLiteral, GrafikCategories
.SetData chDimValues, chDataLiteral, GrafikValues
.Type = chChartTypeColumnClustered
End With
With .Title
.Position = chTitlePositionTop
.Caption = "FİZİKSEL İLERLEME"
.Font.Size = 12
.Font.Color = &H4000&
.Font.Bold = True
End With
End With
.Left = 0
.Top = 36
.Height = Me.InsideHeight - 36
.Width = Me.InsideWidth
End With
End Sub

'Module1

Sub FormAç()
'Open UserForm

On Error Resume Next
Load UserForm1
End Sub

'Class1

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Pencere As Long, ByVal Koordinat As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal Pencere As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal Pencere As Long, ByVal Eylem As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal Pencere As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal Pencere As Long, ByVal Anahtar As Long, ByVal Yoğunluk As Byte, ByVal İkinci_İşaret As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal Pencere As Long, ByVal Eski_Durum As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal FormMenü As Long, ByVal Pozisyon As Long, ByVal İlk_İşaret As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Pencere_Düzeni As Long, ByVal Mesaj As Long, ByVal Değişken1 As Long, Değişken2 As Any) As Long
Dim Çerçeve As Long, Tarz As Long, Logo As Long
Dim i As Integer, Derece As Double
Public Property Set LogoYerleştir(Form As Object)

On Error Resume Next
Logo = Form.Image1.Picture.Handle
Çerçeve = FindWindow(vbNullString, Form.Caption)
Call SendMessage(Çerçeve, &H80, 0&, ByVal Logo)
Call SendMessage(Çerçeve, &H80, 1&, ByVal Logo)
End Property
Public Property Set Form1(Form As Object)

On Error Resume Next
Çerçeve = FindWindow(vbNullString, Form.Caption)
Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong Çerçeve, (-16), Tarz
ShowWindow Çerçeve, 5
'3= Geniş Açar
DrawMenuBar Çerçeve
End Property
Public Property Set FormGörün(Form As Object)

On Error Resume Next
For i = 1 To 255
SetWindowLong Çerçeve, (-20), GetWindowLong(Çerçeve, (-20)) Or &H80000
SetLayeredWindowAttributes Çerçeve, 0, i, &H2
Çerçeve = FindWindow(vbNullString, Form.Caption)
Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong Çerçeve, (-16), Tarz
ShowWindow Çerçeve, 5
'3=Geniş AçarDrawMenuBar Çerçeve
DoEvents
Next i
End Property
Public Property Set FormYokol(Form As Object)

On Error Resume Next
For i = 1 To 255
SetWindowLong Çerçeve, (-20), GetWindowLong(Çerçeve, (-20)) Or &H80000
SetLayeredWindowAttributes Çerçeve, 0, (255 - i), &H2
Çerçeve = FindWindow(vbNullString, Form.Caption)
Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong Çerçeve, (-16), Tarz
ShowWindow Çerçeve, 5
DrawMenuBar Çerçeve
DoEvents
Next i
End Property
Public Property Set FormManuelYokol(Form As Object)

On Error Resume Next
Derece = Form.Slider1.Value
SetWindowLong Çerçeve, (-20), GetWindowLong(Çerçeve, (-20)) Or &H80000
SetLayeredWindowAttributes Çerçeve, 0, (255 - Derece), &H2
Çerçeve = FindWindow(vbNullString, Form.Caption)
Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
SetWindowLong Çerçeve, (-16), Tarz
ShowWindow Çerçeve, 5
DrawMenuBar Çerçeve
DoEvents
End Property
Public Property Set KapatEtkili(Form As Object)

On Error Resume Next
DeleteMenu GetSystemMenu(FindWindow("ThunderDFrame", Form.Caption), 1), &HF060, 0&
DrawMenuBar Çerçeve
End Property
Public Property Set KapatEtkisiz(Form As Object)

On Error Resume Next
DeleteMenu GetSystemMenu(FindWindow("ThunderDFrame", Form.Caption), 0), &HF060, 0&
DrawMenuBar Çerçeve
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