Страница не найдена

Страница, которую вы запрашиваете, не существует.

Копирование, удаление и создание файлов и папок средствами VB.

Можно конечно, написать прогу, в которой одни лишь АПИ-функции, но иногда проще использовать функции, которые нам предлагает старина ВБ, понятное дело - ко всем им есть АПИ-альтернатива, более быстрая, но не стоит попусту забивать модули вашей проги, да и «загрузчивости» нашим программам не помешает :)

Вот что наш родной Бейсик предлагает по работе с файловой системой:

— Операции с файлами:

Kill [путь к файлу]
удаляет файл, не помещая его в Корзину, в аргументе [путь к файлу] можно использовать подстановочные знаки ? и *.
FileCopy [откуда], [куда]
копирует заданный файл.
Name [старое положение] As [новое положение]
функция используется для переименовывания файла, если в аргументах указан то же каталог, и для перемещения файла, если пути в аргументах разные.

— Операции с папками:

RmDir [путь к папке]
удаляет папку, если она пуста. Если там кто-то есть, выполнение функции вызовет ошибку.
MkDir [путь к папке]
напротив, создает новую папку.
ChDir [путь к папке]
изменяет текущий каталог.

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как узнать, существует ли файл или папка?

И снова мы обходимся без АПИ, потому что в ВБ есть замечательная, наверное, самая важная функция для работы с файлами и папками - функция DIR:

DIR [путь], [атрибуты]

Все элементарно - вы задаете функции DIR путь к файлу, а она возвращает этот путь, если файл или папка существует, или возвращает пустую строку, если нет такого имени:

If Dir("C:\My Files\file.txt") = "" Then MsgBox "Увы, такого файла не существует!"

Но здесь есть свои нюансы, которые скрываются в аргументе [атрибуты].
Если его не указывать, программа будет проверять наличие только файлов без аттрибутов «скрытый» и «системный».

Давайте разберемся в его константах:

vbNormal - Если аргумент не указан, функция ставит эту константу
vbHidden - Скрытый файл
vbSystem - Системный файл
vbArchive - Архивный файл
vbReadOnly - Файл с атрибутом «только чтение»
vbDirectory - Обычная папка без атрибутов

А что, если файл и cкрытый, и cистемный? Или мы имеем дело со скрытой папкой?
Надо комбинировать константы, например:

Dir("C:\Skritaya Papka", vbDirectory And vbHidden)

И, напоследок, случай. Что, если мы не знаем точно, скрытый ли это файл или системный? Нам поможет «Or»:

Dir("C:\HiddenOrSystemFile.SYS", vbHidden Or vbSystem)

У функции Dir также есть масса интересных возможностей:

Dir("C:\Windows\System32\*.dll") ' Вернет имя первого файла с расширением DLL в папке System32.
Dir("C:\Windows\System32", vbDirectory) ' Проверит существование System32 в каталоге Windows.
Dir("C:\Windows\System32\", vbDirectory) ' Вернет путь к первой папке (по алфавиту) в каталоге System32

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как узнать имена всех файлов или папок в каталоге?

Здесь нам поможет всемогущий Dir(). Имена можно записывать в список или массив, но лучше всего в коллекцию.

Достать файлы с использованием коллекции:

Dim FilesCol As New Collection, FileName As String
FileName = Dir("C:\", vbNormal)
Do While FileName <> ""
FilesCol.Add FileName
FileName = Dir()
Loop

Можно также в список:

Dim FileNameAs String
FileName = Dir("C:\", vbNormal)
Do While FileName <> ""
List1.AddItem FileName
FileName = Dir()
Loop

В массив по-моему запихивать не выгодно и трудоемко, так что процесс я здесь описывать не буду.

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Получить пути системных папок: Windows, System32, Temp и т.п.

В Visual Basic есть очень полезная функция Environ(), которая возвращает пути системных каталогов.

Environ [выражение]

В аргументе [выражение] можно ввести следующее:

"WINDIR" - путь к системной папке
"TMP" - путь к папке TEMP
"BLASTER" - координаты звуковой карты
"PATH" - пути, объявленные в autoexec.bat

MsgBox "Ваш Windows здесь: " & Environ("WINDIR")

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Получить пути системных папок: Мои документы, Пуск>Программы, Рабочий стол и т.п.

На разных компьютерах путь к папке Мои документы, естественно, разный. Этим страдают и другие системные папки. Если мы хотим узнать путь к папке, скажем «Пуск>Программы», здесь нам Environ() не поможет. Можно обратиться к реестру, а значит поставить в проект огромный модуль от Microsoft, а можно напечатать буквально четыре строчки:

Function GetSpecialFolder(Id%) As String
Dim WSO As Object: Set WSO = CreateObject("WScript.Shell")
GetSpecialFolder = WSO.SpecialFolders(Id)
End Function

Эта функция будет возвращать нам полный путь к системной папке, нам остается лишь указать Id-номер папки. Вот список:

0 - Рабочий стол (для всех пользователей)
1 - Меню «Пуск» (общее)
2 - Пуск>Программы (общее)
3 - Пуск>Программы>Автозагрузка (общее)
4 - Рабочий стол
5 - Папка ApplicationData текущего пользователя
6 - Папка PrintHood текущего пользователя
7 - Папка Шаблоны текущего пользователя
8 - Папка Windows\Fonts
9 - Папка NetHood текущего пользователя

MsgBox "Путь к Вашему Рабочему столу: " & GetSpecialFolder(4)

Функция взята из модуля FSO Examples, в котором содержатся все функции по работе с файловой системой! Его можно скачать в разделе «Исходники».

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как удалить папку, в которой находятся файлы?

В VB6 есть функция RmDir(), которая должна удалять папки, но она вызывает ошибку, если в папке хотя бы один файл.
Следующая функция удалит папку и ее содержимое:

Function FolderKill(Path$)
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFolder (Path)
End Function

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Три способа узнать размер файла.

Первый способ:

Visual Basic содержит хорошую функцию, которая возвращает размер файла в байтах:

FileLen("C:\filik.txt")

Второй способ:

Если вы хотите узнать размер файла, открытого оператором Open, воспользуйтесь функцией LOF (Len Of File). Функции передается номер открытого файла:

LOF(FileNumber)

Третий способ:

Можно воспользоваться функцией из модуля FSO Examples, в котором содержатся все функции по работе с файловой системой. Его можно скачать в разделе «Исходники».

Function FileSize(File$)
Dim RSO As Object: Set RSO = FSO.GetFile(File)
FileSize = RSO.Size
End Function

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как программно создать ярлык?

В первый раз я столкнулся с этой проблемой, когда заканчивал свой первый инсталятор на ВБ. Я искал функцию, создающую ярлык в АПИ, но безуспешно.

Тогда я нашел способ делать это через WScriptShell:

Function CreateShortcut(ShortcutPath$, FilePath$)
Dim WSO As Object: Set WSO = CreateObject("WScript.Shell")
Dim SHO As Object: Set SHO = WSO.CreateShortcut(ShortcutPath)
SHO.TargetPath = FilePath: SHO.Save
End Function

Вот пример использования:

CreateShortcut "C:\Проводник.LNK", "C:\Windows\explorer.exe"

Внимание! По неподтвержденной пока информации, данная функция вызывает Run-Time ошибку в Windows Vista.

Все функции (в том числе и эту) по работе с файловой системой вы можете найти в модуле FSO Examples. Его можно скачать в разделе «Исходники».

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как узнать свободное место на жестком диске?

Следующая функция поможет Вам быстро узнать свободное место на жестком диске в байтах:

Function DriveFreeSpace(Letter$)
Dim FSO As Object: Set FSO = CreateObject("Scripting.FilesSystemObject")
Dim DSO As Object: Set DSO = FSO.GetDrive(FileObject.GetDriveName(Letter))
End Function

Функция взята из модуля FSO Examples, в котором содержатся ВСЕ функции по работе с файловой системой! Его можно скачать в разделе «Исходники».

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Существует ли диск?

Эта функция из модуля FSO Examples (его вы можете скачать в разделе «Исходники») поможет вам узнать, существует ли диск под заданной буквой.

Function DriveExists(Letter$)
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
DriveExists = FSO.DriveExists(Letter)
End Function

Вот как ей пользоваться:

MsgBox DriveExists("d")

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Воспроизведение стандартного звука с Beep.

В ВБ есть функция, может кому и пригодится.

Создайте форму и напишите в ее модуле:

Private Sub Form_Click()
Beep
End Sub

Запустите проект, щелкните по форме, и услышите, что будет.

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как воспроизвести звуковой файл *.WAV?

Создайте новый модуль и объявите в декларациях одну АПИ-шку:

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Const SND_ASYNC = &H1
Const SND_MEMORY = &H4

Воспроизводим звук:

PlaySound(App.Path & "\ERROR.WAV", SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY Or SND_NOSTOP)

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как воспроизвести файл *.WAV из ресурсов?

Откройте в первую очередь файл VB Resource Editor и нажмите «Add Custom Resource...», затем выберите любой WAV-файл для открытия. В списке появилась папка «CUSTOM», а в ней файл «101».

Сохраните файл ресурсов.

Теперь перейдем к проекту: создайте модуль, в декларациях объявите АПИ:

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Const SND_ASYNC = &H1
Const SND_MEMORY = &H4

Затем создайте функцию:

Public Sub ResPlaySound(ByVal ResourceId As Integer)
Dim Ret As Variant
#If Win32 Then
SoundBuffer = StrConv(LoadResData(ResourceId, "CUSTOM"), vbUnicode)
#Else
SoundBuffer = LoadResData(ResourceId, "CUSTOM")
#End If
Ret = sndPlaySound(SoundBuffer, SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY Or SND_NOSTOP)
DoEvents
End Sub

Попробуем воспроизвести звук:

ResPlaySound 101

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Перезагрузка/выключение Windows

Как показывает практика, вопрос выключения и перезагрузки Windows программно интересует очень многих. Я бы тоже хотел внести свою лепту в ответ на этот вопрос. Уже долгое время я пользуюсь этим примером. Что примечательно: при использовании данного примера, система поочередно опрашивает все процессы в системе, и если требуется в какой-либо программе сохранения каких-либо данных, то вы всегда можете сделать отмену процесса выключения компьютера. При использовании данного примера вы можете использовать одну из EWX_-констант.

EWX_LOGOFF - вход в систему под новым именем
EWX_SHUTDOWN - выключение компьютера
EWX_REBOOT - перезагрузка компьютера
EWX_FORCE - принудительный вход под новым именем

Создайте форму и разместите там две кнопки - CompOff и CompReboot:

' Завершает работу Windows
Private Sub CompOff_Click()
Call ShutDown(EWX_SHUTDOWN)
End Sub
' Перезагружает Windows
Private Sub CompReboot_Click()
Call ShutDown(EWX_REBOOT)
End Sub

Теперь создайте новый модуль и разместите там следующий код:

Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)

Public Enum TokenRights
TOKEN_ASSIGN_PRIMARY = &H1
TOKEN_DUPLICATE = &H2
TOKEN_IMPERSONATE = &H4
TOKEN_QUERY = &H8
TOKEN_QUERY_SOURCE = &H10
TOKEN_ADJUST_PRIVILEGES = &H20
TOKEN_ADJUST_GROUPS = &H40
TOKEN_ADJUST_DEFAULT = &H80
TOKEN_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or TOKEN_ASSIGN_PRIMARY Or TOKEN_DUPLICATE Or TOKEN_IMPERSONATE Or TOKEN_QUERY Or TOKEN_QUERY_SOURCE Or TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)
TOKEN_READ = (STANDARD_RIGHTS_READ Or TOKEN_QUERY)
TOKEN_WRITE = (STANDARD_RIGHTS_WRITE Or TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)
TOKEN_EXECUTE = (STANDARD_RIGHTS_EXECUTE)
End Enum

Public Enum PrivilegeAttributes
SE_PRIVILEGE_ENABLED_BY_DEFAULT = &H1
SE_PRIVILEGE_ENABLED = &H2
SE_PRIVILEGE_USED_FOR_ACCESS = &H80000000
End Enum

Public Enum ExitOptions
EWX_LOGOFF = 0
EWX_SHUTDOWN = 1
EWX_REBOOT = 2
EWX_FORCE = 4
End Enum

Public Enum TokenAccess
TokenUser = 1
TokenGroups = 2
TokenPrivileges = 3
TokenOwner = 4
TokenPrimaryGroup = 5
TokenDefaultDacl = 6
TokenType = 8
TokenImpersonationLevel = 9
TokenStatistics = 10
End Enum

Type LUID
lowPart As Long
HighPart As Long
End Type

Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As PrivilegeAttributes
End Type

Type PTOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(0) As LUID_AND_ATTRIBUTES
End Type

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As TokenRights, ByRef TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValueA Lib "advapi32" (ByVal lpSystemName As String, ByVal lpName As String, ByRef lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, ByRef NewState As PTOKEN_PRIVILEGES, ByVal BufferLength As Long, ByRef PreviousState As Long, ByRef ReturnLenght As Long) As Long
Private Declare Function AdjustTokenPrivilegesOld Lib "advapi32" Alias "AdjustTokenPrivileges" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, ByRef NewState As PTOKEN_PRIVILEGES, ByVal BufferLength As Long, ByRef PreviousState As PTOKEN_PRIVILEGES, ByRef ReturnLenght As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As ExitOptions, ByVal dwReserved As Long) As Long

Public Function ShutDown(Operation As ExitOptions) As Long
Dim lngProcess As Long
Dim lngReturn As Long
Dim lngToken As Long
Dim udtLUID As LUID
Dim lngTokenPrivileges As TokenRights
Dim udtTokenPrivNew As PTOKEN_PRIVILEGES
lngProcess = GetCurrentProcess()
lngTokenPrivileges = TOKEN_ADJUST_PRIVILEGES
lngReturn = OpenProcessToken(lngProcess, lngTokenPrivileges, lngToken)
lngReturn = LookupPrivilegeValueA(vbNullString, "SE_SHUTDOWN_NAME", udtLUID)
udtTokenPrivNew.PrivilegeCount = 1
udtTokenPrivNew.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
udtTokenPrivNew.Privileges(0).pLuid = udtLUID
lngReturn = AdjustTokenPrivileges(lngToken, 0, udtTokenPrivNew, 0&, 0, 0&)
ShutDown = ExitWindowsEx(Operation, 0)
End Function

Источник: www.vbnet.ru.

Воспроизведение стандартных звуков Windows.

Итак, в Windows есть стандартные звуки, которые оповещают пользователя, например, об ошибках. Нередко возникает необходимость воспроизвести их в Вашей программе, например, при имитировании MsgBox'а. Бесспорно, можно таскать их с собой, однако многие пользователи попросту заменяют эти звуки на свои. К сожалению Visual Basic позволяет воспроизвести только один стандартный звук, поэтому мы прибегнем к АПИ.

Слава богу, что существует такая полезная функция, как MessageBeep:

Private Declare Function MessageBeep Lib "user32.dll" (ByVal wType As Long) As Long
Const MB_ICONASTERISK = &H40
Const MB_ICONEXCLAMATION = &H30
Const MB_ICONHAND = &H10
Const MB_ICONQUESTION = &H20
Const MB_OK = &H0

Эта функция воспроизводит один из звуков MsgBox'а: ошибка, восклицание, вопрос или информация. Итак, испробуйте функцию MessageBeep:

MessageBeep MB_OK ' Эквивалент функции Beep
MessageBeep MB_ICONQUESTION ' Вопрос
MessageBeep MB_ICONEXCLAMATION ' Восклицание
MessageBeep MB_ICONASTERISK ' Информация
MessageBeep MB_ICONHAND ' Ошибка

Вы также можете скачать мой готовый пример в разделе «Исходники».

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как нанести изображение полупрозрачно?

Сейчас мы будем наносить изображение на форму со степенью прозрачности. Вообще, его можно нанести также и на PictureBox и даже на чужую форму, но для начала остановимся на этом. Итак все что вам нужно - это Visual Basic, форма и Picture1, расположенный на ней с рисунком, желательно небольшим.

Для начала, создайте модуль и поместите следующий код:

Public Declare Function AlphaBlending Lib "msimg32" Alias "AlphaBlend" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BF As Long) As Long

Public Function AlphaBlend(ByVal DestHDC As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal DestWidth As Long, ByVal DestHeight As Long, ByVal srcHDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal AlphaSource As Long) As Long
Dim lngBlend As Long, res As Long
lngBlend = Val("&h" & Hex(AlphaSource) & "00" & "00")
res = AlphaBlending(DestHDC, XDest, YDest, DestWidth, DestHeight, srcHDC, xSrc, ySrc, srcWidth, srcHeight, lngBlend)
AlphaBlend = res
End Function

К функции AplhaBlending мы будем обращаться через функцию-посредника - AlphaBlend, чтобы упростить ввод параметра AlphaSource, который в оригинальную функцию надо вводить в HEX с кучей других дополнений.

Теперь отвлечемся от исходников и вернемся к нашей форме. Для того чтобы наш код работал, нам нужно установить несколько важных свойств и настроек.

Вставьте в процедуру загрузки формы следующий код, жизненно-важный для работы нашей функции:

Me.AutoRedraw = True
Me.ScaleMode = 3
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture1.Visible = False
Picture1.ScaleMode = 3

В этом коде мы также скрыли PictureBox, что он не мешался.

Если вы зайдете в панель свойств VB, то увидите, что у формы и рисунка свойство HasDC = True. Это заставляет Windows создать для этих объектов контекст устройства — область для рисования и содержания графики, она представляется свойством .hDC, которое передается нашей функции с которого она будет рисовать и срисовывать.

Если объект скрыт, VB не перерисовывает его контекст, так что нам необходимо активировать свойство AutoRedraw как у рисунка, так и у формы.
Не менее важно установить у формы и рисунка режим работы с пикселями, так как АПИ-функции работают именно с ними.

Ну, и наступил момент кульминации, все готово, чтобы заработала наша функция. Дополните код загрузки формы последним куском:

Call AlphaBlend(Me.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, 150)

Обратите также внимание на последний параметр. Он отвечает за прозрачность. Наверное, вы удивитесь: как это так - прозрачность 150%? На самом деле никаких процентов здесь нет. Функция работает с цветами в режиме RGB, так что прозрачность от 0 до 255 соответственно.

Ну, ладно, не буду Вас больше мучить, запустите проект и глазейте на форму =)

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как нанести изображение, сделав фоновый цвет прозрачным?

Допустим, вы делаете игру. Вы уже нарисовали кучу анимаций - изображений, где по порядку расположены все кадры, например, движений человечка на белом фоне. Вы делаете игру стандартными средствами ВБ - рисунок вы помещаете в PictureBox, но вот когда начинаете рисовать человечка на форме появляется большая проблемма - даже если изображение записано в GIF с прозрачным фоном, от куда бы вы его не срисовывали — с Image ли, или с PictureBox'а — вокруг него появится белый фон!

Такую проблему ВБ-шными средствами не решишь, зато есть подходящая специально для этого АПИ-функция — DrawTransparent.

Итак, создайте проект с формой, поместите туда модуль и объявите функцию:

Public Declare Function DrawTransparent Lib "msimg32" Alias "TransparentBlt" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long

Теперь вернемся к форме. Итак, нам понадобиться PictureBox с названием Picture1, который содержит в себе рисунок с белым фоном (в примере будет рассматриваться именно белый фон). Кстати, если вы загрузили GIF-изображение с прозрачным фоном, поставьте Picture1.BackColor = vbWhite.

Чтобы наша функция работала, необходимо настроить некоторые свойства у формы и рисунка. В событие Form_Load вставите следующий код:

Me.AutoRedraw = True
Me.ScaleMode = 3
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture1.Visible = False
Picture1.ScaleMode = 3

Если вы зайдете в панель свойств VB, то увидите, что у формы и рисунка свойство HasDC = True. Это заставляет Windows создать для этих объектов контекст устройства - область для рисования и содержания графики, она представляется свойством .hDC, которое передается нашей функции с которого она будет рисовать и срисовывать.
Если объект скрыт, VB не перерисовывает его контекст, так что нам необходимо активировать свойство AutoRedraw как у рисунка, так и у формы.
Не менее важно установить у формы и рисунка режим работы с пикселями, так как АПИ-функции работают именно с ними.

А также, как я заметил, функция работает некорректно, если размер PictureBox'а меньше размера содержащегося в нем рисунка. А сам PictureBox лучше скрыть, чтобы он не мешался.

И вот все готово, чтобы заработала наша функция, дополните процедуру загрузки формы последней строкой:

Call DrawTransparent(Me.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, RGB(255, 255, 255))

Смело запускайте проект и глядите на форму!

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Как добавить собственный пункт в системное меню?

Для тех кто не знает: системное меню — это меню с пунктами «Закрыть», «Свернуть», «Восстановить» и т.д.

Но даже, если оно носит гордое имя «системное» — помните, что это тоже обычное смертное меню. Значит у него есть хэндл, значит в него АПИшно можно добавить в него свои пункты, что мы и сделаем.

Создайте проект, создайте в нем модуль и объявите в нем функции:

Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const GWL_WNDPROC = (-4)
Const WM_SYSCOMMAND = &H112
Dim PrevProc As Long

Public Sub SetWindowProc()
PrevProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub KillWindowProc()
SetWindowLong Form1.hwnd, GWL_WNDPROC, PrevProc
End Sub

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_SYSCOMMAND And wParam = 1000 Then MsgBox "Ну чё, работает? =D", vbQuestion, "Работает?": Exit Function
End Function

А теперь вернемся к нашей форме и дополним ее модуль кодом:

Private Sub Form_Load()
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(hWnd, 0&)
Call AppendMenu(hSysMenu, MF_SEPARATOR, 0&, 0&)
Call AppendMenu(hSysMenu, MF_STRING, 1000, "О системном меню")
SetWindowProc
End Sub

Private Sub Form_Unload(Cancel As Integer)
KillWindowProc
End Sub

Ну и всё, запускайте проект и смотрите меню.

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Мультимедийный заголовок.

Этот термин придумал я довольно давно - когда-то в далеком 2007 я помню как уселся от нечего делать я состряпал код «мультимедийного заголовка» только ради прикола и украшения проги.

Посмотрите, может он и вам подойдет.

Создайте форму, разместите на ней Timer1. Остальную работу выполнит за Вас код:

Private Sub Form_Load()
Me.Caption = ""
Timer1.Interval = 200
Timer1 = True
End Sub

Private Sub Timer1_Timer()
Static scr%
Select Case scr
Case 0
Timer1.Interval = 200
Me.Caption = Mid("Softrate MultiTitle", 1, Len(Me.Caption)) & "_"
If Len(Me.Caption) = Len("Softrate MultiTitle_") Then scr = 1: Timer1.Interval = 1000
Case 1
Timer1.Interval = 100
If Len(Me.Caption) <= 2 Then Me.Caption = "": scr = 2: Timer1.Interval = 1000: Exit Sub
Me.Caption = Mid(Me.Caption, 1, Len(Me.Caption) - 2) & "_"
Case 2
Timer1.Interval = 200
Me.Caption = Mid("Версия 1.0 Alpha", 1, Len(Me.Caption)) & "_"
If Len(Me.Caption) = Len("Версия 1.0 Alpha_") Then scr = 3: Timer1.Interval = 1000
Case 3
Timer1.Interval = 100
If Len(Me.Caption) <= 2 Then Me.Caption = "": scr = 4: Timer1.Interval = 1000: Exit Sub
Me.Caption = Mid(Me.Caption, 1, Len(Me.Caption) - 2) & "_"
Case 4
Timer1.Interval = 200
Me.Caption = Mid("Влад Рубцов", 1, Len(Me.Caption)) & "_"
If Len(Me.Caption) = Len("Влад Рубцов_") Then scr = 5: Timer1.Interval = 1000
Case 5
Timer1.Interval = 100
If Len(Me.Caption) <= 2 Then Me.Caption = "": scr = 6: Timer1.Interval = 1000: Exit Sub
Me.Caption = Mid(Me.Caption, 1, Len(Me.Caption) - 2) & "_"
Case 6
Timer1.Interval = 200
Me.Caption = Mid("Заходите на мой сайт - http://vladikcomper.scanf.su", 1, Len(Me.Caption)) & "_"
If Len(Me.Caption) = Len("Заходите на мой сайт - http://vladikcomper.scanf.su_") Then scr = 7: Timer1.Interval = 1000
Case 7
Timer1.Interval = 100
If Len(Me.Caption) <= 2 Then Me.Caption = "": scr = 0: Timer1.Interval = 1000: Exit Sub
Me.Caption = Mid(Me.Caption, 1, Len(Me.Caption) - 2) & "_"
End Select
End Sub

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Свернуть все окна.

Создайте на вашей форме кнопку Command1. При нажатии на эту кнопку все окна будут сворачиваться.

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_LWIN = &H5B
Const KEYEVENTF_KEYUP = &H2

Private Sub Command1_Click()
Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(&H4D, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
End Sub

Источник: www.vbnet.ru.

Как сделать форму поверх всех окон?

Создайте форму, разместите на ней кнопку Command1 и вставьте код.

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Sub Form_Load()
Call SetWindowPos(Me.hwnd, HWND_TOPMOST, Me.Left \ 15, Me.Top \ 15, Me.Width \ 15, Me.Height \ 15, Flags)
End Sub

Private Sub Command1_Click()
Call SetWindowPos(Me.hwnd, HWND_NOTOPMOST, Me.Left \ 15, Me.Top \ 15, Me.Width \ 15, Me.Height \ 15, Flags)
End Sub

При запуске форма сразу становится поверх всех. Если вам вдруг она надоела или мешается, нажмите Command1.

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/

Зарезервировано.

Как воспроизвести WMA, MP3, MIDI файлы?

Многие программисты знают, как на VB воспроизвести MIDI или WAV файл. Однако MIDI воспроизводится только после небольшого зависания, а, используя WAV для записи музыки, дистрибутив вашей программы будет весить на порядок больше и она станет непригодной для распространения по сети.

Как вы уже догадались, решить такую задачу без постороннего вмешательства VB неподсилу. Для этого нам потребуется библиотека quartz.dll, которая распространяется с DirectX.

Подключите эту библиотеку к вашему проекту через меню Проект>Информация (Project>References), затем создайте новый класс clsSound, и поместите туда следующий код:

Dim snd As IMediaControl
Dim MP As IMediaPosition

Function LoadSound(ByVal SndPath As String)
Set snd = New FilgraphManager
Set MP = snd
snd.RenderFile SndPath
End Function

Function PlaySound()
snd.Run
MP.CurrentPosition = 0
End Function

Function StopSound()
snd.Stop
End Function

Function PauseSound()
snd.Pause
End Function

Public Property Get Position() As Integer
Position = MP.CurrentPosition
End Property

Public Property Let Position(ByVal NewPos%)
MP.CurrentPosition = NewPos
End Property

Теперь создайте новую форму, если у вас еще ее нет, и разместите на ней кнопки Command1 и Command2. Вставьте этот код в модуль формы:

Dim sndPlayer As New clsSound

Private Sub Form_Load()
sndPlayer.LoadSound "C:\1.mp3"
End Sub

Private Sub Command1_Click()
sndPlayer.PlaySound
End Sub

Private Sub Command2_Click()
sndPlayer.StopSound
End Sub

Ну и, напоследок, если вы хотите, чтобы ваша музыка повторялась, вставьте таймер и напишите:

Private Sub Timer1_Timer()
Static LastPos%
If sndPlayer.Position = LastPos Then
sndPlayer.Position = 0
sndPlayer.PlaySound
End If
LastPos = sndPlayer.Position
End Sub

Оригинальная статья Влада Рубцова. https://vladikcomper.scanf.su/