Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Şubat 2011 Pazar

To Run a Screen Saver in Excel, By SystemParametersInfo Function





'UserForm1

'A) Tools\Macro\Security Otions [Picture: 1]
'B) Windows XP® Office 2003® Normal Referance List
'Description: Visual Basic For Applications
'Description: Microsoft Excel 11.0 Object Library
'Description: OLE Automation
'Description: Microsoft Office 11.0 Object Library
Description: Microsoft Forms 2.0 Object Library
'C) UserForm1'e Eklenen Araçlar (Add Tools)
'Image1, Label1, Label2
'CommandButton1, Label3, Label4

Option Explicit
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private 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
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private i As Single, ii As Single
Private Const Ordinat As Long = 10
Private Const Apsis As Long = 6
Private Bellek(1 To Ordinat, 1 To Apsis) As Long
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Excel Process With ScreenSaver By SystemParametersInfo Function"
Application.Visible = False
Application.VBE.MainWindow.Visible = False
Call EkranDüzenle
End Sub
Private Sub UserForm_Terminate()

On Error Resume Next
Application.Visible = True
Call StartScreenSaver(20, False, 0, 0, 0)
End Sub
Private Sub CommandButton1_Click()

On Error Resume Next
Label3.Caption = VBA.Format(VBA.Now(), "hh:mm:ss")
For i = 1 To Ordinat
             For ii = 1 To Apsis
                          Bellek(i, ii) = i * ii
             Next ii
             Call StartScreenSaver(20, True, 0, 0, 1)
Next i
Label4.Caption = VBA.Format(VBA.Now(), "hh:mm:ss")
Call StartScreenSaver(20, False, 0, 0, 0)
End Sub
Private Function StartScreenSaver(uAction, uParam, lpvParam, fuWinIni, dwMilliseconds)

On Error Resume Next
If uParam = True Then
              SystemParametersInfo uAction, uParam, lpvParam, fuWinIni
              SendMessage GetDesktopWindow, &H112&, &HF140&, 0&
              DoEvents
              BlockInput True
              Sleep dwMilliseconds * 1000
              BlockInput False
End If
SystemParametersInfo 0, False, 0, 0
End Function
Private Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 168
.Width = 306
.BackColor = vbWhite
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
With Image1
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.AutoSize = True
.WordWrap = False
.Caption = "Mustafa ULUSARAÇ"
.TextAlign = fmTextAlignCenter
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 36
.Top = 6
.Height = 12
.Font.Bold = True
.ForeColor = vbBlue
End With
With Label2
.AutoSize = True
.WordWrap = False
.Caption = "01ulusarac@superonline.com"
.TextAlign = fmTextAlignCenter
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 36
.Top = 18
.Height = 12
.Font.Bold = True
.ForeColor = vbBlue
End With
With CommandButton1
.Left = 36
.Top = 36
.Height = 24
.Width = 138
.Caption = "Calculate With ScreenSaver"
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = vbBlue
End With
With Label3
.AutoSize = False
.WordWrap = False
.Caption = ""
.TextAlign = fmTextAlignCenter
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.Left = 180
.Top = 36
.Height = 12
.Width = 114
.Font.Bold = True
.ForeColor = vbBlue
End With
With Label4
.AutoSize = False
.WordWrap = False
.Caption = ""
.TextAlign = fmTextAlignCenter
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.Left = 180
.Top = 48
.Height = 12
.Width = 114
.Font.Bold = True
.ForeColor = vbBlue
End With
End With
End Sub

'Module1

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]

Public EffectTip As Double
Sub FormAç()
'Open UserForm

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