Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ocak 2011 Perşembe

Microsoft® VBScript and Object Expressions





'UserForm1

'A) VBProject References List
     'Name: VBA, Description: Visual Basic For Applications, Full Path: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
     'Name: Excel, Description: Microsoft Excel 11.0 Object Library, Full Path: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
     'Name: stdole, Description: OLE Automation, Full Path: C:\WINDOWS\system32\stdole2.tlb
     'Name: Office, Description: Microsoft Office 11.0 Object Library, Full Path: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
     'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, Full Path: C:\WINDOWS\system32\FM20.DLL
     'Name: SpeechLib, Description: Microsoft Speech Object Library, Full Path: C:\Program Files\Common Files\Microsoft Shared\Speech\sapi.dll [Picture:1]
'B) Addition Tools on UserForm1
     'Image1, Label1, Label2
     'TextBox1, TextBox2, ListBox1
'C) Microsoft VBScript and Object Expressions
     'A. Objects
          'a. VBScript RegExp Object
               'a1. Properties: Pattern, Methods: Test (search-string)
               'a2. Properties: IgnoreCase, Methods : Replace (search-string, replace-string)
               'a3. Properties: Global, Methods : Execute (search-string)
                     'Pattern - A string that is used to define the regular expression. This must be set before use of the regular expression object. Patterns are described in more detail below.
                     'IgnoreCase - A Boolean property that indicates if the regular expression should be tested against all possible matches in a string. By default, IgnoreCase is set to False.
                     'Global - A Boolean property that indicates if the regular expression should be tested against all possible matches in a string. By default, Global is set to False.
                     'Test (string) - The Test method takes a string as its argument and returns True if the regular expression can successfully be matched against the string, otherwise False is returned.
                     'Replace (search-string, replace-string) - The Replace method takes 2 strings as its arguments. If it is able to successfully match the regular expression in the search-string, then it replaces that match with the replace-string, and the new string is returned. If no matches were found, then the original search-string is returned.
                     'Execute (search-string) - The Execute method works like Replace, except that it returns               'a Matches collection object, containing a Match object for each successful match. It doesn't modify the original string.
          'b. VBScript Matches Collection Object
               'b1. Properties: Count
               'b2. Properties: Item
                     'Count - A read-only value that contains the number of Match objects in the collection.
                     'Item - A read-only value that enables Match objects to be randomly accessed from the Matches collection object. The Match objects may also be incrementally accessed from the Matches collection object, using a For-Next loop.
         'c. VBScript Match Object
              'c1. Properties: FirstIndex
              'c2. Properties: Length
              'c3. Properties: Value
                    'FirstIndex - A read-only value that contains the position within the original string where the match occurred. This index uses a zero-based offset to record positions, meaning that the first position in a string is 0.
                    'Length - A read-only value that contains the total length of the matched string.
                    'Value - A read-only value that contains the matched value or text. It is also the default value when accessing the Match object.
     'B. Pattern Options
          'a. Position Matching [Position matching involves the use of the ^ and $ to search for beginning or ending of strings. Setting the pattern property to "^VBScript" will only successfully match "VBScript is cool." But it will fail to match "I like VBScript."]
               'a1. Symbol: ^, Function: Only match the beginning of a string. "^A" matches first "A" in "An A+ for Anita."
               'a2. Symbol: $, Function: Only match the ending of a string. "tquot; matches the last "t" in "A cat in the hat"
               'a3. Symbol: \b, Function: Matches any word boundary "ly\b" matches "ly" in "possibly tomorrow."
               'a4. Symbol: \B, Function: Matches any non-word boundary
          'b. Literals [Literals can be taken to mean alphanumeric characters, ACSII, octal characters, hexadecimal characters, UNICODE, or special escaped characters. Since some characters have special meanings, we must escape them. To match these special characters, we precede them with a "\" in a regular expression.]
              'b1. Symbol: Alphanumeric, Function: Matches alphabetical and numerical characters literally.
              'b2. Symbol: \n, Function: Matches a new line
              'b3. Symbol: \f, Function: Matches a form feed
              'b4. Symbol: \r, Function: Matches carriage return
              'b5. Symbol: \t, Function: Matches horizontal tab
              'b6. Symbol: \v, Function: Matches vertical tab
              'b7. Symbol: \?, Function: Matches ?
              'b8. Symbol: \*, Function: Matches *
              'b9. Symbol: \+, Function: Matches +
              'b10. Symbol: \., Function: Matches .
              'b11. Symbol: \, Function: Matches
              'b12. Symbol: \{, Function: Matches {
              'b13. Symbol: \}, Function: Matches }
              'b14. Symbol: \\, Function: Matches \
              'b15. Symbol: \[, Function: Matches [
              'b16. Symbol: \], Function: Matches ]
              'b17. Symbol: \(, Function: Matches (
              'b18. Symbol: \), Function: Matches )
              'b19. Symbol: \xxx, Function: Matches the ASCII character expressed by the octal number xxx.
              'b20. Symbol: \xxx, Function: "\50" matches "(" or chr (40).
              'b21. Symbol: \xdd, Function: Matches the ASCII character expressed by the hex number dd.
              'b22. Symbol: \xdd, Function: "\x28" matches "(" or chr (40).
              'b23. Symbol: \uxxxx, Function: Matches the ASCII character expressed by the UNICODE xxxx.
               'b24. Symbol: \uxxxx, Function: "\u00A3" matches "£".
           'c. Character Classes [Character classes enable customized grouping by putting expressions within [] braces. A negated character class may be created by placing ^ as the first character inside the []. Also, a dash can be used to relate a scope of characters. For example, the regular expression "[^a-zA-Z0-9]" matches everything except alphanumeric characters. In addition, some common character sets are bundled as an escape plus a letter.]
               'c1. Symbol: [xyz], Function: Match any one character enclosed in the character set., "[a-e]" matches "b" in "basketball".
               'c2. Symbol: [^xyz], Function: Match any one character not enclosed in the character set., "[^a-e]" matches "s" in "basketball".
               'c3. Symbol: ., Function: Match any character except \n.
               'c4. Symbol: \w, Function: Match any word character. Equivalent to [a-zA-Z_0-9].
               'c5. Symbol: \W, Function: Match any non-word character. Equivalent to [^a-zA-Z_0-9].
               'c6. Symbol: \d, Function: Match any digit. Equivalent to [0-9].
               'c7. Symbol: \D, Function: Match any non-digit. Equivalent to [^0-9].
               'c8. Symbol: \s, Function: Match any space character. Equivalent to [ \t\r\n\v\f].
               'c9. Symbol: \S, Function: Match any non-space character. Equivalent to [^ \t\r\n\v\f].
          'd. Repetition [Repetition allows multiple searches on the clause within the regular expression. By using repetition matching, we can specify the number of times an element may be repeated in a regular expression.]
               'd1. Symbol: {x}, Function: Match exactly x occurrences of a regular expression., "\d{5}" matches 5 digits.
              'd2. Symbol: {x,}, Function: Match x or more occurrences of a regular expression., "\s{2,}" matches at least 2 space characters.
              'd3. Symbol: {x,y}, Function: Matches x to y number of occurrences of a regular expression., "\d{2,3}" matches at least 2 but no more than 3 digits.
              'd4. Symbol: ?, Function: Match zero or one occurrences. Equivalent to {0,1}., "a\s?b" matches "ab" or "a b".
              'd5. Symbol: *, Function: Match zero or more occurrences. Equivalent to {0,}.
              'd6. Symbol: +, Function: Match one or more occurrences. Equivalent to {1,}.
         'e. Alternation & Grouping [Alternation and grouping is used to develop more complex regular expressions. Using alternation and grouping techniques can create intricate clauses within a regular expression, and offer more flexibility and control.]
             'e1. Symbol: (), Function: Grouping a clause to create a clause. May be nested. "(ab)?(c)" matches "abc" or "c".
             'e2. Symbol: , Function: Alternation combines clauses into one regular expression and then matches any of the individual clauses., "(ab)(cd)(ef)" matches "ab" or "cd" or "ef".
         'f. BackReferences [Backreferences enable the programmer to refer back to a portion of the regular expression. This is done by use of parenthesis and the backslash (\) character followed by a single digit. The first parenthesis clause is referred by \1, the second by \2, etc.]
             'f1. Symbol: ()\n, Function: Matches a clause as numbered by the left parenthesis., "(\w+)\s+\1" matches any word that occurs twice in a row, such as "hubba hubba."
     'C. Example
           '"^\s*((\$\s?)(£\s?))?((\d+(\.(\d\d)?)?)(\.\d\d))\s*(UKGBPGBUSAUSUSD)?)\s*quot;
           '"^\s*…" and "…\s*quot; - means that there can be any number of leading and end space characters, and the input must be on a line by itself
           '"((\$\s?)(£\s?))?" - means an optional $ or £ sign followed by an optional space
           '"((\d+(\.(\d\d)?)?)(\.\d\d))" - searches for at least one digit, followed by an optional decimal and two digits (which are optional) or a decimal and two digits. This means that input such as 6., 23.33, .88 are all allowed, but 5.5 is not.
           '"\s*(UKGBPGBUSAUSUSD)?" - means that any number of space characters are valid followed by optional and acceptable arguments to the string.

Option Explicit
Private i As Single
Private No As Double, Uzunluk As Double
Private Metin As String, Kelime As String
Private ObjRegExp As Object
Private Eleman, Küme, Change
Private WithEvents Seslendirme As SpVoice
Private Sub UserForm_Initialize()
     On Error Resume Next
     Me.Caption = "[PBİD®] Microsoft VBScript and Object Expressions"
     Call EkranDüzenle
     Call VeriDüzenle
     Set Seslendirme = New SpVoice
End Sub
Private Sub ListBox1_Click()
     On Error Resume Next
     No = ListBox1.ListIndex
     Uzunluk = (ListBox1.List(No, 2) - ListBox1.List(No, 0))
     Kelime = ListBox1.List(No, 1)
     TextBox1.SelStart = ListBox1.List(No, 0)
     TextBox1.SelLength = Uzunluk
     TextBox1.SetFocus
     TextBox2.SelStart = ListBox1.List(No, 0)
     TextBox2.SelLength = Uzunluk
     TextBox2.SelText = ListBox1.List(No, 1)
     Seslendirme.Speak Kelime, SVSFlagsAsync
     VBA.DoEvents
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
     On Error Resume Next
     For i = 0 To (ListBox1.ListCount - 1)
          No = i
          Uzunluk = (ListBox1.List(No, 2) - ListBox1.List(No, 0))
          Kelime = ListBox1.List(No, 1)
          TextBox1.SelStart = ListBox1.List(No, 0)
          TextBox1.SelLength = Uzunluk
          TextBox1.SetFocus
          DoEvents
          TextBox2.SelStart = ListBox1.List(No, 0)
          TextBox2.SelLength = Uzunluk
          TextBox2.SelText = ListBox1.List(No, 1)
          Seslendirme.Speak Kelime, SVSFlagsAsync
          DoEvents
     Next i
End Sub
Private Sub EkranDüzenle()
     On Error Resume Next
     With Me
          .Height = 256
          .Width = 426
          '.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\VectorBackround.jpg")
          .Picture = Resim(URL1)
          .PictureAlignment = fmPictureAlignmentTopLeft
          .PictureSizeMode = fmPictureSizeModeStretch
          .PictureTiling = False
          With Image1
               .Left = 6
               .Top = 6
               .Height = 24
               .Width = 24
               .BorderColor = vbWhite
               .BorderStyle = fmBorderStyleSingle
               .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
               .Top = 6
               .Left = 36
               .Height = 12
               .Width = 228
               .AutoSize = False
               .BackStyle = fmBackStyleTransparent
               .BorderStyle = fmBorderStyleNone
               .Caption = "Mustafa ULUSARAÇ"
               .Font.Bold = True
               .ForeColor = vbBlue
               .SpecialEffect = fmSpecialEffectFlat
               .TextAlign = fmTextAlignLeft
          End With
          With Label2
               .Top = 18
               .Left = 36
               .Height = 12
               .Width = 228
               .AutoSize = False
               .BackStyle = fmBackStyleTransparent
               .BorderStyle = fmBorderStyleNone
               .Caption = "01ulusarac@superonline.com"
               .Font.Bold = True
               .ForeColor = vbBlue
               .SpecialEffect = fmSpecialEffectFlat
               .TextAlign = fmTextAlignLeft
          End With
          With TextBox1
               .Left = 6
               .Top = 36
               .Height = 93.75
               .Width = 258
               .BackStyle = fmBackStyleTransparent
               .AutoTab = True
               .AutoSize = False
               .AutoWordSelect = True
               .BorderStyle = fmBorderStyleSingle
               .BorderColor = &HFFFF80
               .Font.Bold = False
               .ForeColor = vbBlue
               .Locked = True
               .MultiLine = True
               .ScrollBars = fmScrollBarsBoth
               .SpecialEffect = fmSpecialEffectFlat
          End With
          With TextBox2
               .Left = 6
               .Top = 133
               .Height = 93.75
               .Width = 258
               .BackStyle = fmBackStyleTransparent
               .AutoTab = True
               .AutoSize = False
               .AutoWordSelect = True
               .BorderStyle = fmBorderStyleSingle
               .BorderColor = &HFFFF80
               .Font.Bold = False
               .ForeColor = &H404000
               .Locked = True
               .MultiLine = True
               .ScrollBars = fmScrollBarsBoth
               .SpecialEffect = fmSpecialEffectFlat
          End With
          With ListBox1
               .Left = 267
               .Top = 36
               .Height = (TextBox2.Top + TextBox2.Height) - TextBox1.Top
               .Width = 150
               .BorderColor = &HFFFF80
               .BorderStyle = fmBorderStyleSingle
               .BackColor = vbWhite
               .ColumnCount = 3
               .ColumnWidths = "36;72;36"
               .ForeColor = vbBlue
               .ListStyle = fmListStylePlain
               .Locked = False
               .MultiSelect = fmMultiSelectSingle
               .SpecialEffect = fmSpecialEffectFlat
          End With
     End With
End Sub
Private Sub VeriDüzenle()
     On Error Resume Next
     TextBox1.Text = "VBScript Regular Expressions Regular expression reference and examples for VBScript. Regular expressions in VBScript are two words that can bring many to their knees, weeping, but they are not as scary as some would have you believe. With their roots in Perl, regular expressions in VBScript use similar syntax, and the chances are that you may already be familiar with the concepts here if you have played with regular expression matching before."
     Metin = TextBox1.Text
     Set ObjRegExp = VBA.CreateObject("VBScript.RegExp")
     With ObjRegExp
          .Pattern = "\w+"
          .IgnoreCase = False
          .Global = True
          Set Küme = .Execute(Metin)
     End With
     No = 0
     For Each Eleman In Küme
          ListBox1.AddItem (Eleman.FirstIndex & " ")
          ListBox1.List(No, 1) = Eleman.Value
          ListBox1.List(No, 2) = VBA.Len(Eleman.Value) + (Eleman.FirstIndex & " ")
          No = No + 1
     Next
     For i = 0 To ListBox1.List((No - 1), 2)
          TextBox2.Text = TextBox2.Text & "_" '" "
     Next i
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 URL As String
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Kılavuzu [UserFormBackround]
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 Icon]
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
'Sub ReferenceList()
     'On Error Resume Next
     'Dim Eleman, No
     'No = 1
     'For Each Eleman In ThisWorkbook.VBProject.References
          'Cells(No, 1) = "Name: "
          'Cells(No, 2) = Eleman.Name
          'Cells(No, 3) = ", Description: "
          'Cells(No, 4) = Eleman.Description
          'Cells(No, 5) = ", Full Path: "
          'Cells(No, 6) = Eleman.FullPath
          'No = No + 1
     'Next Eleman
'End Sub

8 Ocak 2011 Cumartesi

ShockWave File [swf] Animation



'UserForm1

'A) VBProject References List

'A1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'A2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'A3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'A4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'A5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL
'A6) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\WINDOWS\system32\MSCOMCTL.OCX

'B) Addition Tools on UserForm1

'B1)Frame1
'B2)Frame1\Image1, Label1, Label2
'B3)ComboBox1

Option Explicit
Dim i As Single
Private ActiveX As Control
Dim swFile As String
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Shock Wave File [swf] Animation"
Call EkranDüzenle
Call Resim_Ekle(Me)
Call UserForm_Tip1(Me)

End Sub
Private Sub UserForm_Resize()

On Error Resume Next
With ActiveX

.Top = 60
.Left = 6
.Height = Me.InsideHeight - .Top - 6
.Width = Me.InsideWidth - .Left - 6
.SetFocus

End With
With ComboBox1

.Top = 36
.Left = 6
.Height = 18
.Width = Me.InsideWidth - .Left - 6

End With

End Sub
Private Sub UserForm_Terminate()

On Error Resume Next
ActiveX.Playing = False
Application.Visible = True

End Sub
Private Sub ComboBox1_Click()

On Error Resume Next
swFile = ComboBox1.List(ComboBox1.ListIndex, 1)
With ActiveX

.Playing = False
.Playing = True
.LoadMovie 0, swFile
.Play
.SetFocus

End With

End Sub
Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 414
.Width = 636
.BackColor = vbWhite
With Frame1

.Caption = ""
.Left = -1
.Top = -1
.Height = 30
.Width = Me.Width + 12
.Picture = Resim(URL1)
.Picture = LoadPicture("C:\*.jpg")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.SpecialEffect = fmSpecialEffectFlat
With Image1

.Left = 1.5
.Top = 1.5
.Height = 24
.Width = 24
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
.Picture = Resim(URL2)
.Picture = LoadPicture("C:\*.ico")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip

End With
With Label1

.Left = 1.5 + 24 + 3
.Top = 1.5
.Caption = "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With
With Label2

.Left = 1.5 + 24 + 3
.Top = 13.5
.Caption = "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
.Height = 12
.Width = 180
.Font.Bold = True
.ForeColor = vbBlue

End With

End With
With ComboBox1

.ListIndex = -1
.Left = 6
.Top = 36
.Height = 18
.Width = Me.InsideWidth - .Left - 6
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.ForeColor = vbBlue
.Font.Bold = True
.AddItem "Celine Dion [My heart will go on ]": ComboBox1.List(0, 1) = "https://media.dreamhost.com/mp4/player.swf?file=http://video.ak.fbcdn.net/cfs-ak-snc4/48526/46/1487798708433_61271.mp4"
.AddItem "Celine Dion [When i need you]": ComboBox1.List(1, 1) = "https://www.4shared.com/flash/player.swf?file=http://video.l3.fbcdn.net/cfs-l3-snc4/70055/725/455700840418_47831.mp4"
.AddItem "Barış Manço [Kol düğmeleri]": ComboBox1.List(2, 1) = "https://www.4shared.com/flash/player.swf?file=http://video.ak.fbcdn.net/cfs-ak-snc6/79056/256/150352078347010_45641.mp4"
.AddItem "Celine Dion [Beauty and The Beast]": ComboBox1.List(3, 1) = "http://fliiby.com/embed/gadget.swf?fileID=138747&fileShort=7udcoycw70"
.AddItem "Kanal D [Program Akışı]": ComboBox1.List(4, 1) = "http://cdn.dogantv.com.tr/Uploads/loadedbanner/miniplayer_yedek.swf"
.AddItem "Ata Demirer [BKM]": ComboBox1.List(5, 1) = "http://video.google.com/googleplayer.swf?docId=2865758229414156184"
.AddItem "Leconcombre [Animation1]": ComboBox1.List(6, 1) = "http://www.leconcombre.com/stock/calmbay3nail.swf"
.AddItem "Leconcombre [Animation2]": ComboBox1.List(7, 1) = "http://www.leconcombre.com/stock/atomicsmall.swf"

End With
Set ActiveX = Me.Controls.Add("ShockwaveFlash.ShockwaveFlash.10", "ShockwaveFlash1", "1")
With ActiveX

.Top = 60
.Left = 6
.Height = Me.InsideHeight - .Top - 6
.Width = Me.InsideWidth - .Left - 6
.SetFocus

End With
.Move (Application.Width - Me.Width) / 2, (Application.Height - Me.Height) / 2, Me.Width, Me.Height

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 Klavuzu [Vector Backround]
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 Icon]
Public Const URL3 As String = "http://4.bp.blogspot.com/_hsHTxo_5L8E/TKHXL1-dHVI/AAAAAAAAClo/xxJAhuSHReI/s1600/seven-shine-1024-768.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
Public URL As String
Private Enum WindowStyles 'Enumerate windows styles

WS_OVERLAPPED = &H0
WS_POPUP = &H80000000
WS_CHILD = &H40000000
WS_MINIMIZE = &H20000000
WS_VISIBLE = &H10000000
WS_DISABLED = &H8000000
WS_CLIPSIBLINGS = &H4000000
WS_CLIPCHILDREN = &H2000000
WS_MAXIMIZE = &H1000000
WS_BORDER = &H800000
WS_DLGFRAME = &H400000
WS_VSCROLL = &H200000
WS_HSCROLL = &H100000
WS_SYSMENU = &H80000
WS_THICKFRAME = &H40000
WS_GROUP = &H20000
WS_TABSTOP = &H10000
WS_MINIMIZEBOX = &H20000
WS_MAXIMIZEBOX = &H10000
WS_CAPTION = WS_BORDER Or WS_DLGFRAME
WS_TILED = WS_OVERLAPPED
WS_ICONIC = WS_MINIMIZE
WS_SIZEBOX = WS_THICKFRAME
WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
WS_POPUPWINDOW = WS_POPUP Or WS_BORDER Or WS_SYSMENU
WS_CHILDWINDOW = WS_CHILD

End Enum
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal WindowStyles As Long) As Long
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private hForm As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal Index As Long) As Long
Private IList As New ImageList
Private hImage As Long
Private UWind As Long
Sub Form_Aç() 'Open UserForm

Application.Visible = False
Load UserForm1

End Sub
Public Function UserForm_Tip1(UForm As UserForm) 'Enumerated windows styles [X][X][X]

If Val(Application.Version) = 8 Then

hForm = FindWindow("ThunderXFrame", UForm.Caption)

Else

hForm = FindWindow("ThunderDFrame", UForm.Caption)

End If
SetWindowLong hForm, -16, WS_CAPTION + WS_SYSMENU + WS_MINIMIZEBOX + WS_MAXIMIZEBOX
ShowWindow hForm, 5

End Function
Public Function Resim_Ekle(UForm As UserForm) 'Add icon on sysmenu

IList.ListImages.Add 1, "R1", LoadPicture("C:\Program Files\Microsoft Office\OFFICE11\MSN.ico")
hImage = IList.ListImages(1).Picture
If Val(Application.Version) = 8 Then

UWind = FindWindow("ThunderXFrame", UForm.Caption)

Else

UWind = FindWindow("ThunderDFrame", UForm.Caption)

End If
If UWind = 0 Then Exit Function
SendMessage UWind, &H80, True, hImage: SendMessage UWind, &H80, False, hImage
SetWindowLong UWind, (-20), GetWindowLong(UWind, (-20)) And Not &H1
DrawMenuBar UWind

End Function
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 References_List()

' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1

' Next Eleman

'End Sub

3 Ocak 2011 Pazartesi

Flash Window Information



'UserForm1

'A) Normal Reference List

'A1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'A2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'A3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'A4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'A5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL
'A6) Name: WMPLib, Description: Windows Media Player, FullPath: C:\WINDOWS\system32\wmp.dll

'B) Add Tools

'B1) Image1
'B2) Label1
'B3) Label2
'B4) WindowsMediaPlayer1

Option Explicit
Private Type WindowFlashInformation

cbSize As Long
hwnd As Long
dwFlags As Long
uCount As Long
dwTimeout As Long

End Type
Private WFI As WindowFlashInformation
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FlashWindowEx Lib "user32" (pfwi As WindowFlashInformation) As Boolean
Private hWind As Long
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Flash Window Information"
Call Ekran_Düzenle
hWind = FindWindow(vbNullString, Me.Caption)

End Sub
Private Sub UserForm_Activate()

On Error Resume Next
With WFI

.cbSize = Len(WFI)
.dwFlags = &H1 Or &H2 Or &H4 'Window flashing for Window Caption and TaskBar Button, until the stop flag is set.
'.dwFlags = &HC 'Window flashing until the window comes to the foreground.
'.dwFlags = 0 'Stop flashing. The system restores the window to its original state.
.dwTimeout = 0
.hwnd = hWind
.uCount = 0

End With
FlashWindowEx WFI

End Sub
Private Sub Ekran_Düzenle()

On Error Resume Next
With Me

.BackColor = vbWhite
.Height = 302
.Width = 378
.Picture = Resim(URL1)
'.Picture = LoadPicture("c:\*.bmp")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False

End With
With Image1

.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.BackStyle = fmBackStyleTransparent
.Picture = Resim(URL2)
'.Picture = LoadPicture("c:\*.ico")
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.Top = 6
.Left = 6
.Height = 24
.Width = 24

End With
With Label1

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

End With
With Label2

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

End With
With WindowsMediaPlayer1

.Top = 36
.Left = 6
.Height = 234
.Width = 360
.URL = "http://www.musiconline.com.br/somzera/videos/arq/videoclipes/CelineDion-MyHeartWillGoOn.wmv"

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 Klavuzu [Vector Backround]
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 Icon]
Public Const URL3 As String = "http://4.bp.blogspot.com/_hsHTxo_5L8E/TKHXL1-dHVI/AAAAAAAAClo/xxJAhuSHReI/s1600/seven-shine-1024-768.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
Public URL As String
Sub Form_Aç() '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
'Sub References_List()

' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1

' Next Eleman

'End Sub

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi