Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Aralık 2006 Cuma

Call File Manager by Api Functions



'Module1

Option Explicit
Public Type BROWSEINFO

hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Type RECT

Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Const WM_USER = &H400
Public Const MAX_PATH = 260
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_EDITBOX = &H10
Public Const BIF_VALIDATE = &H20
Public Const BIF_NEWDIALOGSTYLE = &H40
Public Const BIF_BROWSEINCLUDEURLS = &H80
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_SHAREABLE = &H8000
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
Public Const BFFM_VALIDATEFAILED = 3
Public Const BFFM_SETSTATUSTEXTA = WM_USER + 100
Public Const BFFM_ENABLEOK = WM_USER + 101
Public Const BFFM_SETSELECTIONA = WM_USER + 102
Public Const BFFM_SETSELECTIONW = WM_USER + 103
Public Const BFFM_SETSTATUSTEXTW = WM_USER + 104
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" (hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" (ByVal hProject As Long, ByVal strFunctionName As String, ByRef strFunctionId As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As String, ByRef lpfn As Long) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17

Sub Demo()
On Error Resume Next
Dim RetStr As String, Flags As Long, DoCenter As Boolean
Flags = Flags + BIF_RETURNONLYFSDIRS + BIF_EDITBOX + BIF_VALIDATE + BIF_STATUSTEXT + BIF_BROWSEINCLUDEFILES + BIF_NEWDIALOGSTYLE
DoCenter = xlOn
RetStr = GetDirectory(CurDir, Flags, DoCenter, "[PBİD®]Kaynak Dosyanızı Seçiniz...")
If RetStr <> "" Then MsgBox RetStr
End Sub
Public Function AddrOf(strFuncName As String) As Long
On Error Resume Next
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
Function GetDirectory(InitDir As String, Flags As Long, CntrDlg As Boolean, Msg) As String
On Error Resume Next
Dim CntrDialog As Boolean
Dim bInfo As BROWSEINFO
Dim pidl As Long, lpInitDir As Long
CntrDialog = CntrDlg
bInfo.pidlRoot = 0
bInfo.lpszTitle = Msg
bInfo.ulFlags = Flags
lpInitDir = LocalAlloc(LPTR, Len(InitDir) + 1)
CopyMemory ByVal lpInitDir, ByVal InitDir, Len(InitDir) + 1
bInfo.lParam = lpInitDir
If (Val(Application.Version) > 8) Then
bInfo.lpfn = BrowseCallBackFuncAddress
Else
bInfo.lpfn = AddrOf("BrowseCallBackFunc")
End If
pidl = SHBrowseForFolder(bInfo)
GetDirectory = GetPathFromID(pidl)
CoTaskMemFree pidl
LocalFree lpInitDir
End Function
Function BrowseCallBackFunc(ByVal hwnd As Long, ByVal Msg As Long, ByVal lParam As Long, ByVal pData As Long) As Long
On Error Resume Next
Dim CntrDialog As Boolean
Select Case Msg
Case BFFM_INITIALIZED
SendMessage hwnd, BFFM_SETSELECTIONA, 1, pData
If CntrDialog Then CenterDialog hwnd
Case BFFM_SELCHANGED
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0, GetPathFromID(lParam)
Case BFFM_VALIDATEFAILED
Beep
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0, "Bad Directory"
BrowseCallBackFunc = 1
Exit Function
End Select
BrowseCallBackFunc = 0
End Function
Function GetPathFromID(ID As Long) As String
On Error Resume Next
Dim Result As Boolean, Path As String * MAX_PATH
Result = SHGetPathFromIDList(ID, Path)
If Result Then
GetPathFromID = Left(Path, InStr(Path, Chr$(0)) - 1)
Else
GetPathFromID = ""
End If
End Function
Function BrowseCallBackFuncAddress() As Long
On Error Resume Next
BrowseCallBackFuncAddress = Long2Long(AddressOf BrowseCallBackFunc)
End Function
Function Long2Long(x As Long) As Long
On Error Resume Next
Long2Long = x
End Function
Sub CenterDialog(hwnd As Long)
On Error Resume Next
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / _
2, (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
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