Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | WinAPI


Rambler's Top100


Counter CO.KZ


Комментарий : Все приведённые примеры актуальны только для 32-bit. Обладателям же 64-bit, необходимо изменить об'явления WinAPI функций. Сделать это поможет статья, опубликованная на официальном сайте Microsoft Совместимость 32- и 64-разрядных версий Office 2010 и файл Win32API_PtrSafe.txt, который можно скачать там же.



    [0] [1] [2] [3]

  1. Как используя функции WinAPI получить имя компьютера ? 31.07.2007
  2. Как используя функции WinAPI получить имя пользователя ? 04.08.2007
  3. Как используя функции WinAPI получить значения переменных среды ? 29.07.2009
  4. Как используя функции WinAPI получить путь к специальной папке Windows ? 10.06.2008
  5. Как используя функции WinAPI получить список всех принтеров ? 22.10.2010
  6. Как найти файл, в т.ч. и во вложенных папках, причём без перебора папок и рекурсии (WinAPI) ? 20.01.2012
  7. Как проверить наличие файла и папки, используя функции WinAPI ? 26.08.2007
  8. Как удалить файл, переместив его в корзину, используя функции WinAPI ? 19.08.2007
  9. Как создать папку, используя функции WinAPI ? 26.08.2007
  10. Как получить имена всех дисков компьютера, а также определить тип каждого из дисков (WinAPI) ? 23.09.2007
  11. Как изменить метку тома (имя диска), используя функцию WinAPI ? 11.09.2007
  12. Как определить количество свободного места на диске (WinAPI) ? 26.04.2008
  13. Как программно очистить корзины (WinAPI) ? 08.08.2010
  14. Как в строке, содержащей имя файла, изменить расширение (WinAPI) ? 26.04.2008
  15. Как извлечь имя файла из полного пути, посредством использования WinAPI ? 04.01.2011
  16. Как получить короткое имя файла/папки из длинного (WinAPI) ? 24.01.2011
  17. Как получить длинное имя файла/папки из короткого (WinAPI) ? 26.06.2011
  18. Как определить какая программа, по умолчанию, открывает указанный файл ? 26.06.2011
  19. Как программно распечатать текстовый, графический и пр. файл ? 17.08.2011
  20. Как программно открыть URL гиперссылку в браузере по умолчанию ? 06.03.2012
  21. Как программно переключить раскладку клавиатуры ? 27.02.2011
  22. Как программно определить текущую раскладку клавиатуры ? NEW 29.09.2016
  23. Как программно получить список всех загруженных раскладок клавиатуры ? NEW 30.09.2016
  24. Как программно узнать состояние клавиш Caps Lock, Num Lock и Scroll Lock ? NEW 09.04.2017
  25. Как используя функции WinAPI сменить рисунок рабочего стола ? 27.07.2009
    [0] [1] [2] [3]


  • Ответ :
  • Private Declare Function GetComputerName _
            Lib "kernel32.dll" Alias "GetComputerNameA" ( _
            ByVal lpBuffer As String, _
            nSize As Long) As Long

    Private Sub WinAPI_ComputerName()
        Dim iComputerName As String * 255

        GetComputerName iComputerName, 255&

        MsgBox "Имя компьютера : " & _
        Application.Clean(iComputerName)
    End Sub

  • Ответ :
  • Private Declare Function GetUserName _
            Lib "advapi32.dll" Alias "GetUserNameA" ( _
            ByVal lpBuffer As String, _
            nSize As Long) As Long

    Private Sub WinAPI_UserName()
        Dim iUserName As String * 255

        GetUserName iUserName, 255&

        MsgBox "Имя пользователя : " & _
        Application.Clean(iUserName)
    End Sub

  • Ответ :

    Для того, чтобы получить значение переменной среды можно использовать различные варианты, например, [FAQ505] VB функцию Environ(), но, к сожалению, этот вариант слишком зависит от версии OC, поэтому в некоторых случаях имеет смысл воспользоваться нижеприведённой функцией WinAPI (пять переменных приведены исключительно в качестве демонстрации)
  • Private Declare Function GetEnvironmentVariable _
            Lib "kernel32.dll" Alias "GetEnvironmentVariableA" ( _
            ByVal lpName As String, _
            ByVal lpBuffer As String, _
            ByVal nSize As Long) As Long
    
    Private Sub WinAPI_EnvironVariables()
        Dim iVariable As String * 255 ', iVarName As Variant
    
        For Each iVarName In Array( _
            "Temp", "WinDir", "UserName", "ComputerName", "OS")
            GetEnvironmentVariable CStr(iVarName), iVariable, 255&
            MsgBox iVarName & ":" & vbNewLine & _
            Application.Clean(iVariable), , ""
        Next
    End Sub
    Комментарий : Для получения временной папки, папки Windows, имени пользователя [FAQ335] и компьютера [FAQ333] можно использовать и другие функции WinAPI, а также возможности, которые предоставляет Windows Script Host (некоторые примеры можно найти здесь)
  • Ответ : Скачать пример

    Для того, чтобы определить путь к специальной папке, можно воспользоваться функциями WinAPI, например, SHGetSpecialFolderPath (пример получения полного пути к папке "Мои документы" прилагается)
  • Private Declare Function SHGetSpecialFolderPath _
            Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" ( _
            ByVal hWnd As Long, _
            ByVal lpszPath As String, _
            ByVal CSIDL As Long, _
            ByVal fCreate As Long) As Long

    Private Sub WinAPI_SpecialFolders()
        Dim iSpecialFolder As String * 255

        SHGetSpecialFolderPath 0&, iSpecialFolder, 5&, 0&

        MsgBox "Мои документы : " & iSpecialFolder, , ""
    End Sub
    Комментарий : Для получения пути к другим папкам Windows, достаточно всего лишь указать нужную константу CSIDL, ознакомиться же со списком основных констант можно скачав этот пример.
  • Ответ : Скачать пример

    Для того, чтобы получить коллекцию, содержащую все принтеры, можно, например, считать соответствующий раздел реестра Windows. Обратите внимание на то, что в данном примере речь идёт о WinNT/2000/XP/
  • Private Const HKEY_LOCAL_MACHINE = &H80000002

    Private Declare Function RegOpenKey _
            Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
            ByVal hKey As Long, _
            ByVal lpSubKey As String, _
            phkResult As Long) As Long
    Private Declare Function RegEnumKey _
            Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
            ByVal hKey As Long, _
            ByVal dwIndex As Long, _
            ByVal lpName As String, _
            ByVal cbName As Long) As Long
    Private Declare Function RegCloseKey _
            Lib "advapi32.dll" ( _
            ByVal hKey As Long) As Long

    Private Sub WinAPI_EnumPrinters()
        Dim iPrinters As New Collection
        Dim ihKey As Long, iCountPrinter As Long
        Dim iKeyName As String, iSubKeyName As String

        iKeyName = "Software\Microsoft\Windows NT\CurrentVersion\Print\Printers"
        iSubKeyName = String(255, 32) 'Space(255)

        RegOpenKey HKEY_LOCAL_MACHINE, iKeyName, ihKey
        Do While RegEnumKey(ihKey, iCountPrinter, iSubKeyName, 255&) = 0
           iCountPrinter = iCountPrinter + 1
           iPrinters.Add Application.Clean(iSubKeyName) 'iSubKeyName
        Loop
        RegCloseKey ihKey
    End Sub

  • Ответ :

    Для того, чтобы определить наличие папки или файла можно использовать различные варианты, например, [FAQ44] VB функцию Dir(), но при необходимости можно воспользоваться и функциями WinAPI :

    Вариант I. SearchPath() Несколько примеров возможного применения см. ниже, только обратите внимание на то, что данная функция не ищет файл/папку во вложенных подпапках (что характерно и для других функций, за исключением SearchTreeForFile) Кроме того, папку, в которой должен осуществляться поиск, и сам искомый файл/папку нужно указывать раздельно.
  • Private Declare Function SearchPath _
            Lib "kernel32.dll" Alias "SearchPathA" ( _
            ByVal lpPath As String, _
            ByVal lpFileName As String, _
            ByVal lpExtension As String, _
            ByVal nBufferLength As Long, _
            ByVal lpBuffer As String, _
            ByVal lpFilePart As String) As Long
    
    Private Sub WinAPI_SearchPathFile()
        Dim iFileName As String * 255, iLength As Long
        
        iLength = SearchPath("C:\WINDOWS", _
        "Explorer", ".exe", 255&, iFileName, vbNullString)
        
        If iLength = 0 Then
           MsgBox "Файл изволит отсутствовать", vbCritical, ""
        Else
           MsgBox Mid(iFileName, 1, iLength), vbInformation, ""
        End If
    End Sub
    
    Private Sub WinAPI_SearchPathFile2()
        Dim iFileName As String * 255, iLength As Long
        
        iLength = SearchPath(vbNullString, "Explorer.exe", _
        vbNullString, 255&, iFileName, vbNullString)
        
        If iLength > 0 Then
           MsgBox Mid(iFileName, 1, iLength), vbInformation, ""
        Else
           MsgBox "Файл изволит отсутствовать", vbCritical, ""
        End If
    End Sub
    
    Private Sub WinAPI_SearchPathFile3()
        Dim iFileName As String * 255, iLength As Long
        
        iLength = SearchPath(Application.Path & "\XLStart", _
        "Personal.xls", vbNullString, 255&, iFileName, vbNullString)
        
        If iLength = 0 Then
           MsgBox "Личной книги макросов не наблюдается"
        Else
           MsgBox Mid(iFileName, 1, iLength)
        End If
    End Sub
    
    Private Sub WinAPI_SearchPathFile4()
        iFileName$ = Space(255)
        
        SearchPath Application.Path, "WinWord.exe", _
        vbNullString, 255&, iFileName$, vbNullString
    
        'SearchPath vbNullString, "WinWord.exe", _
        vbNullString, 255&, iFileName$, vbNullString
        
        If InStr(iFileName$, vbNullChar) > 0 Then
           MsgBox Application.Clean(iFileName$)
        Else
           MsgBox "Word'а нет в папке с Excel'ем"
        End If
    End Sub
    
    Private Sub WinAPI_SearchPathFile5()
        Dim iPath$, iSearchPath$ ', iFileName$
        iPath = "C:\Windows"
        iSearchPath = "System32"
        
        If SearchPath(iPath, iSearchPath, _
           vbNullString, 0&, vbNullString, vbNullString) > 0 Then
           MsgBox iPath & "\" & iSearchPath
        Else
           MsgBox "Папка не найдена ..."
        End If
    End Sub

    Вариант II. PathFileExists()

    Источник : The KPD-Team

    Private Declare Function PathFileExists _
            Lib "shlwapi.dll" Alias "PathFileExistsA" ( _
            ByVal pszPath As String) As Long

    Private Sub WinAPI_IsPathFileExist()
        iPath$ = "C:\Windows"'Or "C:\Windows\"
        iFile$ = "C:\Мои документы\Книга1.xls"

        If CBool(PathFileExists(iPath$)) = True Then
           MsgBox "Папка : " & iPath$ & " существует"
        Else
           MsgBox "Папка : " & iPath$ & " не существует"
        End If

        If CBool(PathFileExists(iFile$)) = True Then
           MsgBox "Файл : " & iFile$ & " существует"
        Else
           MsgBox "Файл : " & iFile$ & " не существует"
        End If
    End Sub

  • Ответ :

    Если Вам необходимо найти и получить полный путь файла, при этом, искомый файл может находиться во вложенных папках, а перебор подпапок нежелателен, то решить такую задачу можно с помощью WinAPI функции SearchTreeForFile()

    Источник : The KPD-Team SearchTreeForFile
  • Ответ :

    Как известно, инструкция Kill [FAQ15], равно как некоторые методы об'екта FileSystemObject [FAQ336] удаляют файл(ы) не перемещая их в корзину, однако, если у Вас возникнет потребность удалить файл, с возможностью его восстановления (при условии, что в свойствах корзины не установлена опция Уничтожать файлы сразу после удаления, не помещая их в корзину), то можно использовать следующий вариант :
  • Private Type SHFILEOPSTRUCT
        hWnd As Long
        wFunc As Long
        pFrom As String
        pTo As String
        fFlags As Integer
        fAnyOperationsAborted As Long
        hNameMappings As Long
        lpszProgressTitle As String
    End Type

    Private Declare Function SHFileOperation _
            Lib "shell32.dll" Alias "SHFileOperationA" ( _
            lpFileOp As SHFILEOPSTRUCT) As Long

    Private Sub WinAPI_DeleteFile()
        Dim iSHFOperation As SHFILEOPSTRUCT

        iFileName$ = "C:\Мои документы\DeleteFile.xls"
        'укажите существующий файл, подлежащий удалению

        With iSHFOperation
             .wFunc = 3&
             .pFrom = iFileName$
             .fFlags = 64& 'Вывести подтверждение удаления, удалить-переместить в корзину и показать процесс удаления(прогресс-бар)
             '.fFlags = 68& 'Вывести подтверждение удаления, удалить-переместить в корзину, но не показывать процесс удаления
             '.fFlags = 80& 'Удалить в корзину, но не выводить сообщение и не показывать процесс удаления
        End With

        SHFileOperation iSHFOperation
    End Sub

  • Ответ :

    Как известно, инструкция MkDir [FAQ152] позволяет создать последнюю папку для указанного пути, но эта папка будет создана только при условии существования родительской папки. Если же родительская папка отсутствует, то Вы получите ошибку, которую можно избежать, если воспользоваться вариантом из вышеприведённой ссылки, или, например, следующими функциями WinAPI :
  • Private Declare Function SHCreateDirectory _
            Lib "shell32.dll" Alias "#165" ( _
            ByVal hWnd As Long, _
            ByVal pszPath As String) As Long

    Private Sub WinAPI_MkDir()
        SHCreateDirectory 0&, "C:\Мои документы\Архив\Документы\Счета"
    End Sub

    Private Sub WinAPI_MkDirUnicode()
        SHCreateDirectory 0&, StrConv("C:\Мои документы\Архив\Документы\Счета", vbUnicode)
    End Sub
    Примечание : Минимальные требования, при использовании данной функции, наличие Windows 2000 (тестирование первого примера, кстати, проводилось именно в этой версии)
    Private Declare Function SHCreateDirectory _
            Lib "shell32.dll" ( _
            ByVal hWnd As Long, _
            ByVal pszPath As Long) As Long

    Private Sub WinAPI_MkDir2()
        SHCreateDirectory 0&, StrPtr("C:\Мои документы\Архив\Документы\Счета")
    End Sub
    Вариант II. Источник : The KPD-Team
    Private Declare Function MakeSureDirectoryPathExists _
            Lib "imagehlp.dll" ( _
            ByVal lpPath As String) As Long

    Private Sub WinAPI_MkDir2()
        MakeSureDirectoryPathExists "C:\Мои документы\Архив\Документы\Счета"
    End Sub

  • Ответ : Скачать пример
  • Private Declare Function GetDriveType Lib "kernel32.dll" _
            Alias "GetDriveTypeA" ( _
            ByVal nDrive As String) As Long

    Private Declare Function GetLogicalDriveStrings Lib "kernel32.dll" _
            Alias "GetLogicalDriveStringsA" ( _
            ByVal nBufferLength As Long, _
            ByVal lpBuffer As String) As Long

    Private Sub WinAPI_Get_Logical_Drives()
        iLogicalDrive& = GetLogicalDriveStrings(0, iBuferString$)
        iBuferString$ = Space(iLogicalDrive&)
        iLogicalDrive& = GetLogicalDriveStrings(iLogicalDrive&, iBuferString$)

        For iCount& = 1 To iLogicalDrive& Step 4
            iDrive$ = Mid(iBuferString$, iCount&, 3)
            iType$ = Choose(GetDriveType(iDrive$), _
            "Не существует, что вряд ли", "С'ёмный диск", _
            "Жёсткий диск", "Сетевой диск", "CD-ROM", "RAM")
            MsgBox _
            "Диск : " & UCase(iDrive$) & vbNewLine & _
            "Тип диска : " & iType$, vbExclamation, ""
        Next
    End Sub

  • Ответ :
  • Private Declare Function SetVolumeLabel _
            Lib "kernel32.dll" Alias "SetVolumeLabelA" ( _
            ByVal lpRootPathName As String, _
            ByVal lpVolumeName As String) As Long

    Private Sub WinAPI_SetVolumeLabel()
        SetVolumeLabel "C:\", "Temp_Drive" 'наличие \ обязательно
    End Sub

  • Ответ :
  • Private Declare Function GetDiskFreeSpace _
            Lib "kernel32.dll" Alias "GetDiskFreeSpaceA" ( _
            ByVal lpRootPathName As String, _
            lpSectorsPerCluster As Long, _
            lpBytesPerSector As Long, _
            lpNumberOfFreeClusters As Long, _
            lpTotalNumberOfClusters As Long) As Long

    Private Sub WinAPI_DiskFreeSpace()
        Dim iSectorsCluster&, iBytesSector&
        Dim iNumberOfFreeClusters&, iTotalNumberOfClusters&

        iDrive$ = "C:\" 'укажите нужный диск

        GetDiskFreeSpace "C:\", iSectorsCluster&, _
        iBytesSector&, iNumberOfFreeClusters&, iTotalNumberOfClusters&

        MsgBox "Свободно : " & _
        iSectorsCluster& * iBytesSector& * iNumberOfFreeClusters& & " байт"
    End Sub
    Комментарий : Если использование этой функции не даёт нужного результата, то воспользуйтесь вторым вариантом, который опубликован ниже.
    Private Declare Function SHGetDiskFreeSpace _
            Lib "shell32.dll" Alias "SHGetDiskFreeSpaceA" ( _
            ByVal pszVolume As String, _
            pqwFreeCaller As Currency, _
            pqwTotal As Currency, _
            pqwFree As Currency) As Long

    Private Sub WinAPI_SHDiskFreeSpace()
        Dim iDrive$, iCaller@, iTotalBytes@, iFreeBytes@

        iDrive$ = "C:\" 'укажите нужный диск

        SHGetDiskFreeSpace iDrive$, iCaller@, iTotalBytes@, iFreeBytes@

        MsgBox "Свободно : " & iFreeBytes@ * 10000 & " байт"
    End Sub

  • Ответ :
  • Private Declare Function SHEmptyRecycleBin _
            Lib "shell32.dll" Alias "SHEmptyRecycleBinA" ( _
            ByVal hWnd As Long, _
            ByVal pszRootPath As String, _
            ByVal dwFlags As Long) As Long

    Private Sub WinAPI_EraseRecycleBin()
        SHEmptyRecycleBin 0&, vbNullString, 2&

        '0 - Показать диалоговое окно подтверждающее удаление файлов и процесс удаления(прогресс-бар)
        '1 - Очищать корзину без подтверждений и прогресс-бара
        '2 - Показать диалоговое окно подтверждающее удаление файлов, но не показывать прогресс-бар
    End Sub

  • Ответ :
  • Private Declare Function PathRenameExtension _
            Lib "shlwapi.dll" Alias "PathRenameExtensionA" ( _
            ByVal pszFileName As String, _
            ByVal pszExtension As String) As Long

    Private Sub WinAPI_ChangeExtension()
        Dim iFileName As String
        iFileName = "C:\Мои документы\Годовой_отчёт.xls"

        PathRenameExtension iFileName, ".doc"
    End Sub
    Примечание : Функция WinAPI PathRenameExtension не проверяет наличие файла и не меняет расширение у существующего файла. Она всего лишь изменяет строку, содержащую указанное имя файла, меняя старое расширение на новое. Если же строка не содержит расширения, то эта строка остаётся без изменений.
  • Ответ :
  • Private Declare Sub PathStripPath _
            Lib "shlwapi.dll" Alias "PathStripPathA" ( _
            ByVal pszPath As String)

    Private Sub WinAPI_PathStripPath()
        Dim iFullName As String
        iFullName = "C:\Program Files\Office_97\Excel.exe"

        PathStripPath iFullName

        MsgBox "Имя файла : " & iFullName, vbExclamation, ""
    End Sub
    Примечание : Обратите внимание на то, что PathStripPath не проверяет наличие об'екта, а просто позволяет получить последнюю составляющую пути, в т.ч. и папку.
    Private Declare Sub PathStripPath _
            Lib "shlwapi.dll" Alias "PathStripPathA" ( _
            ByVal pszPath As String)

    Private Sub WinAPI_Test()
        Dim iFullName As String, iFileName As String
        Dim iApplicationPath As String, iPath As String

        iFullName = "C:\Program Files\Office_97\Excel.exe" '"Хрень"
        iFileName = GetPathName(iFullName)

        MsgBox iFullName & String(2, 10) & iFileName

        iApplicationPath = Application.Path
        iPath = GetPathName(iApplicationPath)

        MsgBox iApplicationPath & String(2, 10) & iPath
    End Sub

    Function GetPathName(ByVal iPath As String) As String
        PathStripPath iPath

        If iPath Like "*" & vbNullChar & "*" Then _
        GetPathName = Left(iPath, InStr(iPath, vbNullChar) - 1)
    End Function
    Для удаления 'мусора' Вы можете также использовать и возможности самого Excel, например :
    Function GetPathName(ByVal iPath As String) As String
        PathStripPath iPath
        If InStr(iPath, vbNullChar) > 0 Then
           GetPathName = Application.Clean(iPath)
        End If
    End Function
    Function GetPathName(ByVal iPath As String) As String
        PathStripPath iPath

        GetPathName = _
        IIf(InStr(iPath, vbNullChar), Application.Trim(iPath), "")
    End Function

  • Ответ :

    Для того, чтобы с помощью WinAPI функции GetShortPathName получить из длинного имени файла/папки - короткое, можно использовать любой из двух нижеопубликованных вариантов. Обратите внимание на то, что данная функция, видимо, проверяет наличие файла/папки, т.к. в случае их отсутствия, Вы не получите короткое имя. Если Вам понадобится обратное действие, то Вы можете использовать эти варианты [FAQ640], [FAQ590] или об'ект Shell
  • Private Declare Function GetShortPathName _
            Lib "kernel32.dll" Alias "GetShortPathNameA" ( _
            ByVal lpszLongPath As String, _
            ByVal lpszShortPath As String, _
            ByVal cchBuffer As Long) As Long

    Private Sub WinAPI_GetShortPathName()
        Dim iPath As String, iShortName As String * 255

        iPath = Application.Path

        GetShortPathName iPath, iShortName, 255&

        MsgBox "Короткое имя папки :" & vbCrLf & _
        Application.Clean(iShortName), vbInformation, ""
    End Sub

    Private Sub WinAPI_GetShortFileName()
        Dim iFileName$, iShortName$, iLenght&

        iFileName = ThisWorkbook.FullName
        iShortName = Space(255)

        iLenght = GetShortPathName(iFileName, iShortName, 255&)
        iShortName = Left(iShortName, iLenght)

        MsgBox "Короткое имя файла :" & vbCrLf & iShortName
    End Sub

  • Ответ :

    Для того, чтобы получить из короткого имени файла/папки - длинное, можно применить следующие варианты [FAQ590] , [FAQ591], но можно воспользоваться WinAPI функцией GetLongPathName. Обратите внимание на то, что данная функция, видимо, проверяет наличие файла/папки, т.к. в случае их отсутствия, Вы не получите длинное имя.
  • Private Declare Function GetLongPathName _
            Lib "kernel32.dll" Alias "GetLongPathNameA" ( _
            ByVal lpszShortPath As String, _
            ByVal lpszLongPath As String, _
            ByVal cchBuffer As Long) As Long

    Private Sub WinAPI_GetLongPathName()
        Dim iShortPath As String, iLongName As String * 255

        iShortPath = "C:\PROGRA~1\" 'для примера

        GetLongPathName iShortPath, iLongName, 255&

        MsgBox "Длинное имя папки :" & vbCrLf & _
        Application.Clean(iLongName), vbInformation, ""
    End Sub

    Private Sub WinAPI_GetLongFileName()
        Dim iShortFileName$, iLongName$, iLenght&

        iShortFileName = "C:\WINDOWS\АДМИНИ~1.XLB" 'для примера
        iLongName = Space(255)

        iLenght = GetLongPathName(iShortFileName, iLongName, 255&)
        iLongName = Left(iLongName, iLenght)

        MsgBox "Длинное имя файла :" & vbCrLf & iLongName
    End Sub

  • Ответ :

    Для того, чтобы с помощью WinAPI получить название программы, которая, по умолчанию, открывает указанный файл, можно воспользоваться нижеприведённым кодом. Обратите внимание на то, некоторые типы файлов могут быть и не связаны с определённой программой, к примеру, файлы с расширением .bas , которые по сути, являются текстовыми и открываются в т.ч. простым текстовым редактором "Блокнот", могут и не иметь ассоциаций.
  • Private Declare Function FindExecutable _
            Lib "shell32.dll" Alias "FindExecutableA" ( _
            ByVal lpFile As String, _
            ByVal lpDirectory As String, _
            ByVal lpResult As String) As Long
    
    Private Sub WinAPI_FindExecutable()
       Dim iProgram As String * 255, iFileName As Variant
       
       iFileName = Application.GetOpenFileName()
       If iFileName <> False Then
          If FindExecutable(CStr(iFileName), vbNullString, iProgram) > 32 Then
             MsgBox Application.Clean(iProgram), , ""
          Else
             MsgBox "В реестре ничего не найдено ...", , ""
          End If
       End If
    End Sub

  • Ответ :

    Для того, чтобы с помощью WinAPI распечатать текстовый файл, можно воспользоваться следующим вариантом :
  • Private Declare Function ShellExecute _
            Lib "shell32.dll" Alias "ShellExecuteA" ( _
            ByVal hWnd As Long, _
            ByVal lpOperation As String, _
            ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, _
            ByVal nShowCmd As Long) As Long
    
    Private Sub WinAPI_PrintTextFile()
        ShellExecute 0&, "Print", _
        "C:\Мои документы\Баланс2009.txt", vbNullString, vbNullString, 0&
        
        ShellExecute 0&, "Print", "Баланс2010.txt", _
        vbNullString, "C:\Мои документы", 0& '"C:\Мои документы\"
    End Sub
    Если же текстовый файл необходимо предварительно выбрать, а также определить, был ли отправлен на печать нужный файл, то :
    Private Sub WinAPI_PrintTextFile2()
       Dim iFileName As Variant
       
       iFileName = Application.GetOpenFileName( _
       FileFilter:="Text Files (*.txt),*.txt", Title:="Выберите файл")   
       If iFileName <> False Then
          If ShellExecute(0&, "Print", _
             CStr(iFileName), vbNullString, vbNullString, 0&) > 32 Then
             MsgBox "Файл " & iFileName & " был отправлен на печать", , ""
          Else
             MsgBox "К сожалению, распечатать файл не удалось", , ""
          End If
       Else
          MsgBox "Для печати необходимо выбрать нужный файл", , ""
       End If
    End Sub
    Private Sub WinAPI_PrintTextFile3()
       Dim iFileName As Variant
       
       iFileName = Application.GetOpenFilename( _
       FileFilter:="Text Files (*.txt),*.txt", Title:="Выберите файл")
       If iFileName <> False Then
          If ShellExecute(0&, "Print", _
             CStr(iFileName), vbNullString, vbNullString, 0&) > 32 Then
             MsgBox "Файл " & iFileName & " был отправлен на печать", , ""
             Exit Sub
          End If
       End If
       MsgBox "Ничего интересного не произошло", , ""
    End Sub
    Комментарий : Подобным образом можно отправить на печать и файлы других типов, в т.ч. и графические, правда для этого, они должны быть связаны с определённой программой.
  • Ответ :

    Для того, чтобы с помощью WinAPI открыть указанную URL гиперссылку в браузере, который используется системой по умолчанию, можно воспользоваться следующим вариантом, естественно, указав свою гиперссылку ... хотя можно и оставить всё как есть.
  • Private Declare Function ShellExecute _
            Lib "shell32.dll" Alias "ShellExecuteA" ( _
            ByVal hWnd As Long, _
            ByVal lpOperation As String, _
            ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, _
            ByVal nShowCmd As Long) As Long
    
    Private Sub WinAPI_OpenHyperLink()
        Dim iHyperlink$
        iHyperlink = "http://www.msoffice.nm.ru"
        ShellExecute 0&, "Open", iHyperlink, vbNullString, vbNullString, 1&
    End Sub

  • Ответ :

    Для того, чтобы активировать следующую раскладку клавиатуры, можно воспользоваться нижеопубликованным макросом. Обратите внимание на то, что при наличии двух раскладок (Рус/Eng) последовательный вызов этого макроса приведёт к переключению раскладок с русского на английский, и наоборот.
  • Private Declare Function ActivateKeyboardLayout _
            Lib "user32.dll" ( _
            ByVal HKL As Long, _
            ByVal flags As Long) As Long
    
    Private Sub WinAPI_SetNextKeyboard()
        ActivateKeyboardLayout 1&, 0&
    End Sub
    Вариант II. Если использование данной функции нежелательно, то воспользуйтесь следующим вариантом, который опубликован ниже (автор второго варианта, к сожалению, неизвестен)
    Private Declare Function LoadKeyboardLayout _
            Lib "user32.dll" Alias "LoadKeyboardLayoutA" ( _
            ByVal pwszKLID As String, _
            ByVal flags As Long) As Long
    
    Private Sub KBDToENG()
        LoadKeyboardLayout "00000409", &H1
    End Sub
    
    Private Sub KBDToRUS()
        LoadKeyboardLayout "00000419", &H1
    End Sub

  • Ответ :

    Для того, чтобы с помощью функций WinAPI, определить текущую раскладку, можно воспользоваться нижеопубликованным макросом. Обратите внимание на то, что полученный результат сверяется лишь с двумя раскладками, а именно Рус/Eng, но Вы можете расширить этот перечень.
  • Private Declare Function GetKeyboardLayoutName _
            Lib "user32.dll" Alias "GetKeyboardLayoutNameA" ( _
            ByVal pwszKLID As String) As Long
    
    Private Sub WinAPI_GetKeyboardName()
        Dim keyBoardName As String * 8
        GetKeyboardLayoutName keyBoardName
        
        Select Case keyBoardName
            Case "00000419": MsgBox "RU Русский"
            Case "00000409": MsgBox "EN Английский(США)"
        End Select
    End Sub

  • Ответ : Скачать пример

    Для того, чтобы с помощью функций WinAPI, получить список всех доступных в настоящий момент, раскладок клавиатуры, можно воспользоваться нижеопубликованным макросом. Если же на Вашем компьютере, среди загруженных языков, могут встречаться и другие, то более подробный список языков можно найти в примере. Только при тестировании примера имейте ввиду, что несмотря на то, что идентификаторы у таких(см.ниже) раскладок различаются, это один и тот же язык.

    Английский (США)
    Английский (Канада)
    Английский (Южная Африка)
    ...

    Узбекский (кириллица)
    Узбекский (латиница)
  • Private Const LANG_ENGLISH As Long = &H9
    Private Const LANG_RUSSIAN As Long = &H19
    Private Const LANG_UKRAINIAN As Long = &H22
    
    Private Declare Function GetKeyboardLayoutList _
            Lib "user32.dll" ( _
            ByVal nBuff As Long, _
            ByRef lpList As Long) As Long
    
    Private Sub WinAPI_GetKeyboardList()
        Dim iCount&, iArr&()
        iCount = GetKeyboardLayoutList(0&, 0&): ReDim iArr(1 To iCount)
        iCount = GetKeyboardLayoutList(iCount, iArr(1))
        For iCount = 1 To iCount
            Select Case iArr(iCount) And 255&
                Case LANG_RUSSIAN:   MsgBox "RU Русский"
                Case LANG_ENGLISH:   MsgBox "EN Английский"
                Case LANG_UKRAINIAN: MsgBox "UA Украiнский"
            End Select
        Next
    End Sub

  • Ответ :

    Для того, чтобы с помощью функций WinAPI, узнать состояние некоторых клавиш, а именно Caps Lock, Num Lock и Scroll Lock , можно использовать любой из нижеопубликованных вариантов.

    Вариант I. Скачать пример
  • Private Const VK_CAPITAL As Long = &H14
    Private Const VK_NUMLOCK As Long = &H90
    Private Const VK_SCROLL As Long = &H91
    
    Private Declare Function GetKeyState _
            Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
            
    Private Sub WinAPI_GetKeyState()
        If GetKeyState(VK_CAPITAL) = 1 Then
           MsgBox "Caps Lock светится", , "Состояние индикатора"
        Else
           MsgBox "Caps Lock не светится", , "Состояние индикатора"
        End If
        
        If GetKeyState(VK_NUMLOCK) = 1 Then
           MsgBox "Num Lock светится", , "Состояние индикатора"
        Else
           MsgBox "Num Lock не светится", , "Состояние индикатора"
        End If
        
        If GetKeyState(VK_SCROLL) = 1 Then
           MsgBox "Scroll Lock светится", , "Состояние индикатора"
        Else
           MsgBox "Scroll Lock не светится", , "Состояние индикатора"
        End If
    End Sub
    Private Sub WinAPI_GetKeyState2() 'Lite Version
        MsgBox "Caps Lock " & _
        IIf(GetKeyState(VK_CAPITAL), "светится", "не светится"), , "Состояние индикатора"
        
        MsgBox "Num Lock " & _
        IIf(GetKeyState(VK_NUMLOCK), "светится", "не светится"), , "Состояние индикатора"
    
        MsgBox "Scroll Lock " & _
        IIf(GetKeyState(VK_SCROLL), "", "не ") & "светится", , "Состояние индикатора"
    End Sub
    Вариант II.
    Private Const VK_CAPITAL As Long = &H14
    Private Const VK_NUMLOCK As Long = &H90
    Private Const VK_SCROLL As Long = &H91
    
    Private Declare Function GetKeyboardState _
            Lib "user32.dll" (ByRef pbKeyState As Byte) As Long
    
    Private Sub WinAPI_GetKeyboardState()
        Dim iArrKeyState(255) As Byte
        GetKeyboardState iArrKeyState(0)
        
        If iArrKeyState(VK_CAPITAL) = 1 Then
           MsgBox "Caps Lock светится", , "Состояние индикатора"
        Else
           MsgBox "Caps Lock не светится", , "Состояние индикатора"
        End If
        
        If iArrKeyState(VK_NUMLOCK) = 1 Then
           MsgBox "Num Lock светится", , "Состояние индикатора"
        Else
           MsgBox "Num Lock не светится", , "Состояние индикатора"
        End If
        
        If iArrKeyState(VK_SCROLL) = 1 Then
           MsgBox "Scroll Lock светится", , "Состояние индикатора"
        Else
           MsgBox "Scroll Lock не светится", , "Состояние индикатора"
        End If
    End Sub

  • Ответ : Скачать пример

    Для того, чтобы сменить рисунок рабочего стола, достаточно воспользоваться функцией WinAPI, а именно, SystemParametersInfo (не забыв предварительно указать/выбрать нужный файл .bmp)
  • Private Declare Function SystemParametersInfo _
            Lib "user32.dll" Alias "SystemParametersInfoA" ( _
            ByVal uAction As Long, _
            ByVal uiParam As Long, _
            ByRef pvParam As Any, _
            ByVal fWinIni As Long) As Long
    
    Private Sub WinAPI_ChangeWallPaper()
        iFileName$ = "C:\Мои рисунки\Мои коты\001.bmp"
        
        SystemParametersInfo 20&, 0&, ByVal iFileName$, 3&
    End Sub

    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

    © 2004-2017 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff