Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Mayıs 2012 Perşembe

CreateCaret Function




'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: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'5) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) Label3, TextBox1
'3) Label4, TextBox2
'4) Label5, TextBox3
Option Explicit
Private i As Single
Private Declare Function CreateCaret Lib "user32" (ByVal hwnd As Long, ByVal hBitmap As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private hFocus As Long
Private hShow As Long
Private CB As CommandBar
Private CBB As CommandBarButton
Private hCBB(1 To 1000) As New MSForms.Image
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] CreateCaret Function"
Call Ekran_Kur
Call Get_CBBImage
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
hFocus& = GetFocus&()
Call CreateCaret(hFocus&, hCBB(360).Picture, 16, 16)
hShow& = ShowCaret&(hFocus&)
End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
hFocus& = GetFocus&()
Call CreateCaret(hFocus&, 1, 16, 16)
hShow& = ShowCaret&(hFocus&)
End Sub
Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
hFocus& = GetFocus&()
Call CreateCaret(hFocus&, hCBB(359).Picture, 16, 16)
hShow& = ShowCaret&(hFocus&)
End Sub
Private Sub Get_CBBImage()
On Error Resume Next
Set CB = Application.CommandBars(1)
For i = 1 To 740
Set CBB = CB.Controls.Add(Type:=msoControlButton)
CBB.FaceId = i
Set hCBB(i).Picture = CBB.Picture
CBB.Delete
Next i
End Sub
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 118
.Width = 252
.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 Label3
.Left = 6
.Top = 36
.Height = 18
.Width = 24
.Caption = "Veri1"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With TextBox1
.Left = 30
.Top = 36
.Height = 18
.Width = 210
.Value = "Veri1"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.ForeColor = vbBlue
End With
With Label4
.Left = 6
.Top = 54
.Height = 18
.Width = 24
.Caption = "Veri2"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With TextBox2
.Left = 30
.Top = 54
.Height = 18
.Width = 210
.Value = "Veri2"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.ForeColor = vbBlue
End With
With Label5
.Left = 6
.Top = 72
.Height = 18
.Width = 24
.Caption = "Veri3"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With TextBox3
.Left = 30
.Top = 72
.Height = 18
.Width = 210
.Value = "Veri3"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.ForeColor = vbBlue
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ç()
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 yorum:

Servis dedi ki...

Marka tasarım adına, bilgi paylaşımlarınız için teşekkür ederiz.

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