Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2011 Salı

Writeln Web Document


'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
'6) Name: SHDocVw, Description: Microsoft Internet Controls, FullPath: C:\Windows\SysWOW64\ieframe.dll
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) WebBrowser1
Option Explicit
Private i As Single
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 hwnd As Long, ByVal hWndInsertAfter 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 hwnd As Long, lpRect As RECT) As Long
Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd 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 POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Boyut As RECT
Private Eleman As Worksheet
Private hwnd As Long
Private AnimateWidth As Integer
Private AnimateHeight As Integer
Private FormWidth As Integer
Private FormHeight As Integer
Private FormLeft As Integer
Private FormTop As Integer
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Writeln Web Document"
hwnd = FindWindow(vbNullString, Me.Caption)
With Application
.Visible = False
.DisplayAlerts = False
Call Add_Web_Document_Sheet
Call Ekran_Duzenle
Call Writeln_Web_Document
Call Form_Animate
.DisplayAlerts = False
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 36 + 6 + 252 + 12
.Width = 6 + 372 + 6
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
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 = 420
.Caption = "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 = 420
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With WebBrowser1
.Left = 6
.Top = 36
.Height = 252
.Width = 368
.FullScreen = False
.Resizable = False
.TheaterMode = False
.Navigate "about:blank"
Do While WebBrowser1.Busy
DoEvents
Loop
End With
End With
End Sub
Private Sub Add_Web_Document_Sheet()
On Error Resume Next
For Each Eleman In ThisWorkbook.Sheets
If Eleman.Name = "WebDocumen" Then GoTo Devam
Next Eleman
ThisWorkbook.Sheets.Add Sheets(1)
ActiveSheet.Name = "WebDocumen"
Devam:
With Sheets("WebDocumen")
.Cells.Select
Selection.Delete Shift:=xlUp
.Range("A1").Select
.Cells(1, 1) = "@Object Classid='Clsid:6BF52A52-394A-11d3-B153-00C04F79FAA6' Height='300' ID='Player1' Width='472'æ"
.Cells(2, 1) = "@Param Name='URL' value='http://scfire-ntc-aa04.stream.aol.com:80/stream/1004'/æ"
.Cells(3, 1) = "@Param Name='volume' value='50'/æ"
.Cells(4, 1) = "@Param Name='playCount' value='2'/æ"
.Cells(5, 1) = "@Param Name='uiMode' value='mini'/æ"
.Cells(6, 1) = "@/Objectæ"
.Cells(7, 1) = "@Body Scroll='No' Style='Border-Width:0'/æ"
.Cells(8, 1) = "@Body BackGround='http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp'/æ"
End With
Cells.Replace What:="@", Replacement:="<", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="æ", Replacement:=">", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Private Sub Writeln_Web_Document()
On Error Resume Next
DoEvents
WebBrowser1.Document.Open
i = 1
With ThisWorkbook.Sheets("WebDocumen")
Do While .Cells(i, 1) <> ""
WebBrowser1.Document.writeln .Cells(i, 1).Text
i = i + 1
Loop
.Delete
End With
End Sub
Sub Form_Animate()
On Error Resume Next
AnimateWidth = GetSystemMetrics32(0)
AnimateHeight = GetSystemMetrics32(1)
GetWindowRect hwnd, Boyut
FormWidth = VBA.Abs(Boyut.Right - Boyut.Left)
FormHeight = VBA.Abs(Boyut.Top - Boyut.Bottom)
FormLeft = (AnimateWidth - FormWidth) / 2
FormTop = (AnimateHeight - FormHeight) / 2
SetWindowPos hwnd, 0&, FormLeft, FormTop, 0&, 0&, &H1
AnimateWindow hwnd, 800, &H10 Or &H20000
Me.Repaint
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

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

1 Aralık 2011 Perşembe

Save Web Pages And Objects By ExecWB

'Module1

'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: SHDocVw, Description: Microsoft Internet Controls, Full Path: C:\WINDOWS\system32\ieframe.dll
Option Explicit
Private Url As String
Private IE As New InternetExplorer
Sub ExecWB()
On Error GoTo Hata
IE.Visible = True
Url = "http://www.excelkodklavuzu.blogspot.com"
IE.Navigate Url
Do
DoEvents
Loop While Not IE.ReadyState = 4
IE.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
Exit Sub
Hata:
MsgBox VBA.Err.Description, vbInformation, "[PBİD®]"
End Sub
'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

20 Kasım 2011 Pazar

GetSystemMenu Options For Excel, WorkBook And UserForm


'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) Image1, Label1, Label2
'2) Label3, Label4, Label5, Label6, Label7, Label8
'3) ToggleButton1, ToggleButton2, ToggleButton3
'4) ToggleButton4, ToggleButton5, ToggleButton6
'5) ToggleButton7, ToggleButton8, ToggleButton9
Private i As Single
Private Const GWL_STYLE = -16&
Private Const SC_CLOSE = &HF060
Private Const MF_BYCOMMAND = &H0
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal myHwnd As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal myHwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private hMenu As Long
Private hWndStyle As Long
Private UFhWnd As Long
Private XLhWnd As Long
Private WBhWnd As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] GetSystemMenu Options For Excel, WorkBook And UserForm"
Call Ekran_Duzenle
Call Find_hWnd
Call Open_Buttons
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Call Open_Buttons
End Sub
Private Sub ToggleButton1_Click()
On Error Resume Next
With Me.ToggleButton1
If .Value Then
Call AddMinButton(UFhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMinButton(UFhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton2_Click()
On Error Resume Next
With Me.ToggleButton2
If .Value Then
Call AddMaxButton(UFhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMaxButton(UFhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton3_Click()
On Error Resume Next
With Me.ToggleButton3
If .Value Then
Call AddCloseButton(UFhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelCloseButton(UFhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton4_Click()
On Error Resume Next
With Me.ToggleButton4
If .Value Then
Call AddMinButton(WBhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMinButton(WBhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
With Application.Windows(ThisWorkbook.Name)
.WindowState = xlMaximized
.WindowState = xlNormal
End With
End Sub
Private Sub ToggleButton5_Click()
On Error Resume Next
With Me.ToggleButton5
If .Value Then
Call AddMaxButton(WBhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMaxButton(WBhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
With Application.Windows(ThisWorkbook.Name)
.WindowState = xlMaximized
.WindowState = xlNormal
End With
End Sub
Private Sub ToggleButton6_Click()
On Error Resume Next
With Me.ToggleButton6
If .Value Then
Call AddCloseButton(WBhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelCloseButton(WBhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
With Application.Windows(ThisWorkbook.Name)
.WindowState = xlMaximized
.WindowState = xlNormal
End With
End Sub
Private Sub ToggleButton7_Click()
On Error Resume Next
With Me.ToggleButton7
If .Value Then
Call AddMinButton(XLhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMinButton(XLhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton8_Click()
On Error Resume Next
With Me.ToggleButton8
If .Value Then
Call AddMaxButton(XLhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelMaxButton(XLhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub ToggleButton9_Click()
On Error Resume Next
With Me.ToggleButton9
If .Value Then
Call AddCloseButton(XLhWnd)
.Caption = "ON"
.ForeColor = VBA.ColorConstants.vbBlue
Else
Call DelCloseButton(XLhWnd)
.Caption = "OFF"
.ForeColor = VBA.ColorConstants.vbRed
End If
End With
End Sub
Private Sub Find_hWnd()
On Error Resume Next
UFhWnd = FindWindow(vbNullString, UserForm1.Caption)
XLhWnd = FindWindow("XLMAIN", Application.Caption)
WBhWnd = FindWindowEx(XLhWnd, 0&, "XLDESK", vbNullString)
WBhWnd = FindWindowEx(WBhWnd, 0&, "EXCEL7", vbNullString)
End Sub
Private Sub AddMinButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle Or WS_MINIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub DelMinButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle And Not WS_MINIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub AddMaxButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle Or WS_MAXIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub DelMaxButton(ByVal hWndTipi As Long)
On Error Resume Next
hWndStyle = GetWindowLong(hWndTipi, GWL_STYLE)
hWndStyle = hWndStyle And Not WS_MAXIMIZEBOX
SetWindowLong hWndTipi, GWL_STYLE, hWndStyle
DrawMenuBar hWndTipi
End Sub
Private Sub AddCloseButton(ByVal hWndTipi As Long)
On Error Resume Next
hMenu = GetSystemMenu(hWndTipi, 1&)
DrawMenuBar hWndTipi
End Sub
Private Sub DelCloseButton(ByVal hWndTipi As Long)
On Error Resume Next
hMenu = GetSystemMenu(hWndTipi, 0&)
DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND
DrawMenuBar hWndTipi
End Sub
Private Sub Open_Buttons()
On Error Resume Next
For i = 1 To 9
Me("ToggleButton" & i).Value = True
Next i
Application.WindowState = xlMaximized
Windows(ThisWorkbook.Name).WindowState = xlMaximized
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 160
.Width = 258
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
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 = 318
.Caption = "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 = 318
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label3
.Left = 6
.Top = 60
.Height = 24
.Width = 60
.Caption = " UserForm"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label4
.Left = 6
.Top = 84
.Height = 24
.Width = 60
.Caption = " WorkBook"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label5
.Left = 6
.Top = 108
.Height = 24
.Width = 60
.Caption = " Excel"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignLeft
End With
With Label6
.Left = 66
.Top = 36
.Height = 24
.Width = 60
.Caption = "Minumum"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With ToggleButton1
.Left = 66
.Top = 60
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton4
.Left = 66
.Top = 84
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton7
.Left = 66
.Top = 108
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With Label7
.Left = 126
.Top = 36
.Height = 24
.Width = 60
.Caption = "Maximum"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With ToggleButton2
.Left = 126
.Top = 60
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton5
.Left = 126
.Top = 84
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton8
.Left = 126
.Top = 108
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With Label8
.Left = 186
.Top = 36
.Height = 24
.Width = 60
.Caption = "Close"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H404000
.TextAlign = fmTextAlignCenter
End With
With ToggleButton3
.Left = 186
.Top = 60
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton6
.Left = 186
.Top = 84
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
With ToggleButton9
.Left = 186
.Top = 108
.Height = 24
.Width = 60
.Caption = ""
.Alignment = fmAlignmentLeft
.BackStyle = fmBackStyleTransparent
.Enabled = True
.SpecialEffect = fmButtonEffectFlat
.TextAlign = fmTextAlignCenter
.WordWrap = False
End With
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}"
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

10 Kasım 2011 Perşembe

Clipboard Functions

'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, Label1, Label2
'2) ListBox1
Option Explicit
Private i As Integer
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Veriler As GUID
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Resimler As uPicDesc
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private OC As Long
Private OCPI As Long
Private hAvail As Long
Private hPtr As Long
Private hPal As Long
Private hCopy As Long
Private lType As Long
Private IPic As IPicture
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Clipboard Functions"
Call Ekran_Duzenle
Call Shape_Create
End Sub
Private Sub Listbox1_Click()
On Error Resume Next
ActiveSheet.Shapes(ListBox1).Copy
Me.Picture = Get_Picture
End Sub
Function Get_Picture(Optional lXlPicType As Long = xlPicture) As IPicture
On Error GoTo Hata
lType = IIf(lXlPicType = xlBitmap, 2, 14)
hAvail = IsClipboardFormatAvailable(lType)
If hAvail <> 0 Then
OC = OpenClipboard(0&)
If OC > 0 Then
hPtr = GetClipboardData(lType)
If lType = 2 Then
hCopy = CopyImage(hPtr, 0, 0, 0, &H4)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
OC = CloseClipboard
If hPtr <> 0 Then Set Get_Picture = Create_Picture(hCopy, 0, lType)
End If
End If
Exit Function
Hata:
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"
End Function
Private Function Create_Picture(ByVal hPic As Long, ByVal hPal As Long, ByVal lType) As IPicture
On Error GoTo Hata
With Veriler
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With Resimler
.Size = Len(Resimler)
.Type = IIf(lType = 2, 1, 4)
.hPic = hPic
.hPal = IIf(lType = 2, hPal, 0)
End With
OCPI = OleCreatePictureIndirect(Resimler, Veriler, True, IPic)
Set Create_Picture = IPic
Exit Function
Hata:
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"
End Function
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 356
.Width = 408
.Picture = Nothing
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.SpecialEffect = fmSpecialEffectFlat
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 = 270
.Caption = "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 = 270
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With ListBox1
.Left = 312
.Top = 6
.Height = 24
.Width = 86
.ColumnCount = 1
.ColumnWidths = "74"
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End Sub
Private Sub Shape_Create()
On Error Resume Next
ActiveSheet.DrawingObjects.Select
Selection.Delete
Range("A1").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangularCallout, 15#, 5.25, 64.5, 31.5).Select
Range("C1").Select: ActiveSheet.Shapes.AddShape(msoShapeFlowchartMultidocument, 97.5, 3#, 91.5, 41.25).Select
Range("E1").Select: ActiveSheet.Shapes.AddShape(msoShapeNoSymbol, 197.25, 3#, 42#, 43.5).Select
Range("A6").Select: ActiveSheet.Shapes.AddShape(msoShapeSun, 5.25, 50.25, 66.75, 73.5).Select
Range("C6").Select: ActiveSheet.Shapes.AddShape(msoShapeDownRibbon, 95.25, 62.25, 142.5, 60#).Select
Range("A12").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0.75, 140.25, 84.75, 12.75).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.SchemeColor = 40
.Patterned msoPattern50Percent
End With
End With
Range("C14").Select: ActiveSheet.Shapes.AddShape(msoShapeRectangle, 96.75, 167.25, 95.25, 10.5).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.BackColor.SchemeColor = 40
.Patterned msoPattern50Percent
End With
End With
ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 85.5, 147#, 60.75, 20).Select
Range("A16").Select: ActiveSheet.Shapes.AddShape(msoShapeStripedRightArrow, 6#, 192.75, 235.5, 26.25).Select
With Selection.ShapeRange
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
With .Fill
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 65
.OneColorGradient msoGradientVertical, 1, 0.23
End With
End With
For i = 1 To ActiveSheet.Shapes.Count
ListBox1.AddItem ActiveSheet.Shapes(i).Name
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}"
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ç()
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