Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Ocak 2010 Cuma

Optional Release Capture In UserForm



'UserForm1

'A) Windows XP® Office 2003® Normal Referance List

'Visual Basic For Aplication
'Microsoft Forms 2.0 Object Library
'Microsoft Excel 11.0 Object Library
'OLE Automation
'Microsoft Office 11.0 Object Library
'B) Windows XP® Office 2003® Auto Add Referance List
'Microsoft Common Controls 6.0 (SP6)
'C) UserForm1'e Eklenen Araçlar (Add Tools)
'Label1, Label2, Label3, Label4, Image1
Option Explicit
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 FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Dim Pencere As Long, Durum As Double
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Private Dosya As String, URL As String
Private Sub UserForm_Initialize()

On Error Resume Next
Application.Visible = False
ThisWorkbook.VBProject.References.AddFromGuid "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}", 2, 0 'Microsoft Windows Common Controls 6.0 (SP6)
URL = "http://umbra.nascom.nasa.gov/eit/images/eit_20050728_2200_304.gif"
Image1.Picture = ResimYükle(URL)
HideTitleBar Me
Call EkranDüzenle
End Sub
Private Sub UserForm_Resize()

On Error Resume Next
Durum = 1
Call EkranDüzenle
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
Me.MousePointer = fmMousePointerArrow
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Application.Visible = True
End Sub
Private Sub Label1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Pencere = FindWindow(vbNullString, Me.Caption)
ReleaseCapture
SendMessage Pencere, &HA1, 2, ByVal 0&
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
Label1.MousePointer = fmMousePointerArrow
Label4.ForeColor = RGB(255, 0, 0)
End Sub
Private Sub Label2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Pencere = FindWindow(vbNullString, Me.Caption)
ReleaseCapture
SendMessage Pencere, &HA1, 2, ByVal 0&
End Sub
Private Sub Label3_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Pencere = FindWindow(vbNullString, Me.Caption)
ReleaseCapture
SendMessage Pencere, &HA1, 17, ByVal 0&
End Sub
Private Sub Label3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Label3.MousePointer = fmMousePointerSizeNWSE
End Sub
Private Sub Label4_Click()

On Error Resume Next
Label4.ForeColor = RGB(0, 0, 255)
Unload Me
End Sub
Private Sub Label4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Label4.ForeColor = RGB(255, 100, 100)
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
Image1.MousePointer = fmMousePointerArrow
End Sub
Private Function DosyaYükle(Adres As String, Dosya As String) As Boolean

DosyaYükle = URLDownloadToFile(0&, Adres, Dosya, &H10, 0&) = 0
End Function
Function ResimYükle(Adres As String) As IPictureDisp

On Error GoTo Hata
Dosya = VBA.String(260, 0)
GetTempFileName "C:\", "UPD", 0, Dosya
Dosya = VBA.Left$(Dosya, VBA.InStr(1, Dosya, VBA.Chr$(0)) - 1)
SetFileAttributes Dosya, &H100
DeleteUrlCacheEntry Adres
If DosyaYükle(Adres, Dosya) = True Then
Set ResimYükle = LoadPicture(Dosya)
VBA.Kill Dosya
Else
VBA.Err.Raise 999
End If
Exit Function
Hata:
Set ResimYükle = LoadPicture("")
VBA.Kill Dosya
Me.Repaint
End Function
Private Sub HideTitleBar(frm As Object)

On Error Resume Next
Call SetWindowLong(FindWindowA(vbNullString, frm.Caption), -16, GetWindowLong(FindWindowA(vbNullString, frm.Caption), -16) And (Not &HC00000))
Call DrawMenuBar(FindWindowA(vbNullString, frm.Caption))
End Sub
Private Sub EkranDüzenle()

On Error Resume Next
If Durum = 1 Then GoTo Durak1
With Me
.BackColor = &H80000016
.Height = 296
.Width = 296
           End With
           Durak1:
           With Image1

.Top = 24
.Left = 6
.Width = UserForm1.Width - 18
.Height = UserForm1.Height - 18 - 18
.SpecialEffect = fmSpecialEffectFlat
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
End With
With Label1
.Top = -2
.Left = -2
.Width = UserForm1.Width + 12
.Height = 20
.Caption = ""
.SpecialEffect = fmSpecialEffectFlat
.Picture = LoadPicture("D:\Mustafa ULUSARAÇ\BLOGSPOT\zarifVİSTA.bmp")
.PicturePosition = fmPicturePositionCenter
End With
With Label2
.Top = 3
.Left = 3
.Width = UserForm1.Width - 3 - 12
.Height = 12
.Caption = "[PBİD®] Optional Release Capture In UserForm"
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.ForeColor = vbBlue
.Font.Bold = True
End With
With Label3
.Top = Me.Height - 12
.Left = Me.Width - 12
.Height = 12
.Width = 12
.Font.Name = "Marlett"
.Font.Bold = False
.Font.Size = 8
.ForeColor = &H808080
.Caption = VBA.Chr(111)
.BorderStyle = fmBorderStyleNone
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft
End With
With Label4
.Top = 2
.Left = Me.Width - 18
.Height = 12
.Width = 12
.Font.Name = "Marlett"
.Font.Bold = True
.Font.Size = 12
.ForeColor = vbRed
.Caption = VBA.Chr(110)
.BorderStyle = fmBorderStyleNone
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft
.ControlTipText = "Kapat/Close"
.ZOrder 0
End With
Me.Repaint
Durum = 0
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