Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Aralık 2011 Cumartesi

ActiveWorkbook FollowHyperlink to Web & e-Mail Address


'UserForm1

'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B. Available Tools List
'1) İmage1; close the UserForm
'2) Label1; ActiveWorkbook FollowHyperlink to web address
'3) Label2; ActiveWorkbook FollowHyperlink to e-mail address
Option Explicit
Private Const Ara = 60
Private Tur As Integer
Private Kontrol As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal HWND As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal HWND As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal HWND As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private hWnd1 As Long, hWnd2 As Long
Private hFrame As String
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] "
Call Ekran_Duzenle
hFrame = IIf(Val(Application.Version) > 8, "ThunderDFrame", "ThunderXFrame")
hWnd1 = FindWindow(lpClassName:=hFrame, lpWindowName:=Me.Caption)
SetWindowLong hWnd1, -16, GetWindowLong(hWnd1, -16) And Not &HC00000
DrawMenuBar hWnd1
Kontrol = True
Application.Visible = False
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Label1.Caption = VBA.Space(Ara) + "Mustafa ULUSARAÇ"
Tur = Ara + VBA.Len("Mustafa ULUSARAÇ")
Call Zamanlama
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
hWnd2 = FindWindow(lpClassName:=hFrame, lpWindowName:=Me.Caption)
ReleaseCapture
SendMessage hWnd2, &HA1, 2, ByVal 0&
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
With Label1
.ForeColor = &HFF0000
.Font.Underline = False
.MousePointer = fmMousePointerArrow
End With
With Label2
.ForeColor = &HFF0000
.Font.Underline = False
.MousePointer = fmMousePointerArrow
End With
With Image1
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleSingle
.MousePointer = fmMousePointerArrow
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Kontrol = False
Application.Visible = True
End Sub
Private Sub Image1_Click()
On Error Resume Next
Image1.SpecialEffect = fmSpecialEffectSunken
DoEvents
Unload Me
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
With Image1
.SpecialEffect = fmSpecialEffectRaised
.MousePointer = fmMousePointerAppStarting
End With
End Sub
Private Sub Label1_Click()
On Error Resume Next
ActiveWorkbook.FollowHyperlink Address:="http://www.excelkodklavuzu.blogspot.com/", NewWindow:=True
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
DoEvents
With Label1
.ForeColor = &HFFC0C0
.Font.Underline = True
.MousePointer = fmMousePointerAppStarting
End With
End Sub
Private Sub Label2_Click()
On Error Resume Next
ActiveWorkbook.FollowHyperlink Address:="Mailto: " & Label2.Caption & "?" & "Subject= Mustafa ULUSARAÇ'ın dikkatine...", NewWindow:=True
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
DoEvents
With Label2
.ForeColor = &HFFC0C0
.Font.Underline = True
.MousePointer = fmMousePointerAppStarting
End With
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.Height = 240
.Width = 360
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectRaised
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 224
.Caption = VBA.Space(Ara) + "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 224
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
End With
End Sub
Private Sub Zamanlama()
On Error Resume Next
Do While Kontrol
Tur = Tur - 1
Label1.Caption = VBA.Right(Label1.Caption, Tur)
Sleep 30
DoEvents
If Tur = 0 Then Call UserForm_Activate
Loop
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}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
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

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