CEMEH Цитата: Если бы только еще знать, что такое dll и WinAPI.
Смотрите сначала в шапке:
WinApi. Лекция из курса "Основы офисного программирования и язык VBA" Если коротко, то можно объяснить, что такое WinApi так. У VBA есть стандартный, но ограниченый набор процедур и функций. Иногда приходится сделать что-то, чего нет в этом наборе, либо есть, но програмиста не устраивает. Например, нам надо вывести диалог выбора имени папки или выбора цвета. В первом случае у VBA есть только диалог "Сохранить как" и "Открыть". Можно ими воспользоваться, а можно сделать средствами WINAPI
[more=Далее....]
1. Добавляем новый модуль в проект со следующим содержимым (см. ниже).
Здесь и происходит взаимодействие с WinAPI. Обратите внимание на строчки типа
Public Declare Function SHGetSpecialFolderLocation Lib "Shell32.DLL". Они означают, что процедура или функция с именем
SHGetSpecialFolderLocation берутся не из вашего кода, не из стандартного набора VBA, а из файла динамической библиотеки
Shell32.DLL. Как я понял (если не прав - поправьте), все процедуры и функции, которые берутся таким же образом из стандартных библиотек системы (*.dll), называются
WinAPI:
Код: Option Explicit
Public Const dhcMaxPath = 260
Public Const dhcNoError = 0&
Public Const dhcErrorExtendedError = 1208&
Public Const MAX_PATH = 260
Public Declare Function SHGetSpecialFolderLocation Lib "Shell32.DLL" (ByVal hwndOwner As Long, ByVal Folder As Long, ByRef idl As Long) As Long ' Shell types
Public Declare Function SHBrowseForFolder Lib "Shell32.DLL" (ByRef bi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "Shell32.DLL" (ByVal idl As Long, ByVal Path As String) As Integer
Public Type BrowseInfo
hwndOwner As Long ' Owner
pidlRoot As Long ' Can be null
strDisplayName As String ' Rcvs display name of folder (32 bytes)
strTitle As String ' title/instructions for user
ulFlags As Long ' 0 or BIF constants
' You won't use any of the following fields, from VBA.
lpfn As Long ' Address for callback: use NULL
lParam As Long ' Passes to callback
iImage As Long ' index to the system image list
End Type
Public Function dhBrowseForFolder( _
ByVal lngCSIDL As Long, ByVal lngBifFlags As Long, strFolder As String, _
Optional ByVal hWnd As Long = 0, _
Optional strTitle As String = "Select Directory") As Long
Dim usrBrws As BrowseInfo
Dim lngReturn As Long
Dim lngIDL As Long
If SHGetSpecialFolderLocation(hWnd, lngCSIDL, lngIDL) = 0 Then
With usrBrws
.hwndOwner = hWnd
.pidlRoot = lngIDL
.strDisplayName = String$(dhcMaxPath, vbNullChar)
.strTitle = strTitle
.ulFlags = lngBifFlags
End With
lngIDL = SHBrowseForFolder(usrBrws)
If lngIDL Then
strFolder = String$(dhcMaxPath, vbNullChar)
If SHGetPathFromIDList(lngIDL, strFolder) Then
strFolder = dhTrimNull(strFolder)
lngReturn = dhcNoError
Else
strFolder = dhTrimNull(usrBrws.strDisplayName)
lngReturn = dhcNoError
End If
Else
lngReturn = dhcErrorExtendedError
End If
Else
lngReturn = dhcErrorExtendedError
End If
dhBrowseForFolder = lngReturn
End Function
Private Function dhTrimNull(ByVal strValue As String) As String
Dim intPos As Integer
intPos = InStr(strValue, vbNullChar)
Select Case intPos
Case 0
dhTrimNull = strValue
Case 1
dhTrimNull = ""
Case Is > 1
dhTrimNull = Left$(strValue, intPos - 1)
End Select
End Function
Excel задумывается, прибор щёлкает, работает.
). 