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