Здравствуйте уважаемые подписчики!

Подошло время на выход очередного выпуска рассылки!
На это неделе было активно голосование "Стоит ли создавать Web-форму отправки ответа или вопроса в рассылке и на сайте?". Голосование мы останавливаем и подводим результаты. Голоса распределились следующим образом:

Да - 10 голосов (76,92%);
Нет - 3 голоса (23,07%).

В общем СПАСИБО всем, кто голосовал за тот или иной вариант. Результат очевиден: Web-форма отправки вопроса и ответов будет в скором времени установлена на сайте. Пока это буду просто формы, а затем уже специально разработанные скрипты, которые максимально облегчат все действия.

Ну не буду Вас отвлекать от лакомого кусочка выпуска, а лишь скажу: До новых встреч!

1. Вопросы, касающиеся другой сферы программирования, а также сферы ПО - НЕ ПРИНИМАЮТСЯ!

2. Письма с указанием ссылок на какой-либо ресурс или сайт будут отвергнуты, либо ссылкы будут заменены на <РЕКЛАМА> и не будут опубликованы в рассылке!

3. Используйте текстовый (не HTML) формат писем при написании вопроса или ответа.

4. ПИСЬМА С СОДЕРЖАНИЕМ ТИПА "ПИШИ СЮДА, Я ТЕБЕ ВЫШЛЮ ИСХОДНИК", ЛИБО "НАПИШИ МНЕ, Я ТЕБЕ ОБЪЯСНЮ" БОЛЬШЕ НЕ ПУБЛИКУЮТСЯ! ЕСЛИ ВЫ ХОТИТЕ ПОДЕЛИТЬСЯ ФАЙЛОМ, ПРИСЫЛАЙТЕ ЕГО АВТОРУ РАССЫЛКИ. ЭТО ВАМ НЕ ФОРУМ И НЕ СЛУЖБА СООБЩЕНИЙ МЕЖДУ ПОДПИСЧИКАМИ!

Сайт был в очередной раз обновлен. На сайте выложено еще 8 новых исходников. В скорем времени ожидается улучшение странички исходников, а также появление новых исходников!

ФОРУМ! Дорогие мои! На сайте есть прекрасный форум, где Вы сможете общаться с другими участниками нашей рассылки, а их у нашей рассылки 3199 (1862 + 1337)!

Темы ФОРУМА:

Visual Basic / Basic не в пачёте?

FAQ Visual Basic / Моя первая программа

FAQ Visual Basic / Установка системных настроек принтера

FAQ Visual Basic / Последняя версия VB

Все об ActiveX / MS Agent's

FAQ Basic / Шифрование данных

Предложения и пожелания / Комментарии к статьям

---

40/ Здраствуйте ! У меня к вам будет один вопрос. Можно ли на ВБ (у меня установлена 6-я версия программы) сделать поиск подключенных компьютеров по локальной сети.Мне нужно узнать их ай-пи адрес и желательно имя компьютера. Я начинающий программист, если можно, обьясните более подробно. Заранее спасибо [Ответить]

---

63/ Здравствуйте! Как сделать столбец для таблицы с помощью VB который будет показывать номера кварталов с min зарплатой(в таблице 4 квартала). Другой столбец - Динамика изменения средней зарплаты по кварталам (рост, падение, колебание, постоянно)\ нужно найти среднее знаение среди записей каждого отдела и чтобы написал динамику изменени, то что напискано в скобках, одно слово. [Ответить]

---

67/ Здравствуйте! У меня к Вам два вопроса по VBA. 1. Мне часто приходится выполнять расчеты в Excel по формулам. Каким образом можно организовать вычисление в цикле так, чтобы после каждого следующего обращения формулы к ячейке X ее содержимое изменялось бы с определенным шагом? 2. При поиске в таблице базы данных какого-либо значения я пользуюсь формулами "ВПР" или "ГПР". Как можно сделать, чтобы при нахождении приближенного значения функция возвращала наименьшее из наибольших значений в строке или столбце списка, а не наибольшее из наименьших, как заложено в формулах? Заранее благодарю. Александр. [Ответить]

---

76/ podskazhite pozhalusta, kak pravil'nee pristupit' k sozdaniu tablic i kakogo roda tablica nujna dlya vvoda, obrabotki i rascheta dannix, na VB.net. mne bazu sozdavat' ne nado. Zaranee spasibo [Ответить]

---

80/ Как прописать на кнопку запуск Microsoft Query? [Ответить]

---

88/ Здравствуйте. У меня такой вопрос: можно ли из VB послать команду так, чтобы включилась удалённая машина в сети, на которой включен WakeUp on LAN. Если да, то как? За ранее спасибо за оказанную помощь! [Ответить]

---

91/ Как записать данные из Excel-таблицы в DBF-файл? [Ответить]

---

98/ Здравствуйте. Пишу программу автоматического обзвона абонентов АТС по модему. Вопрос: как программно отследить момент снятия телефонной трубки и "проиграть" звуковой файл? Заранее спасибо [Ответить]

---

99/ Здравствуйте. Создается регистратор переговоров. Подскажите, пожалуйста, каким образом записать звук в файл, чтобы в дальнейшем можно было открыть его и прослушать? Заранее спасибо. [Ответить]

---

100/ Здравствуйте. Меня интересует протокол ZModem или подобный. Спасибо [Ответить]

---

111/ У меня к компу подключен принтер который в сети сделан общедоступным, можно ли сделать такое, чтобы если кто-то с другого компьютера послал что-нибудь ко мне на печать, то это застопорилось, а то я шнур принтера от компьютера включаю то в лазерный принтер, то в матричный (взависимости от того, что надо печатать), а в винде он у меня установлен как лазерный. А если мне пошлют на печать документ, когда у меня
матричный подключен ??? знаете какая кака-бяка получается...

Заранее благодарен Евгений [Ответить]

---

113/ Я работаю над закачкой группы файлов с ftp через winsock. Подскажите как определить закачался файл полностью или нет? [Ответить]

---

115/ Как при работе в сети при разрыве связи можно узнать, что связь разорвана
удаленным сервером или локальной программой (ошибка 600)? [Ответить]

---

117/ Как сделать чтобы при выборе шрифта с помощью Microsoft CommonDialog менялся
и набор символов (Кириллица, Западноевропейский и т.п.)? Спасибо. [Ответить]

---

119/ Привет всем программистам! Недавно, читая статью об оптимизации приложений,
я столкнулся со следующим вопросом. Для того, чтобы вы меня правильно
поняли, цитирую часть статьи: "...Если вы создали большое приложение,
подумайте о том, как разбить его на более мелкие. Используйте только одну
главную исполняемую программу, которая вызывает другие программы, а также
DDE-технологию для осуществления связей. Когда вы открываете неглавное
приложение, откройте DDE-связь с главным приложением...". Так вот, может ли
кто-нибудь кратко рассказать об DDE-технологии? Я об этом имею лишь общее
понятие. Если можно, то объясните на примере. Заранее благодарю. С
уважением, Алексей. [Ответить]

---

122/ Как сделать чтобы при нажатии на объект ListView НЕ воспроизводился тот
идиотский звук, который воспроизводится? [Ответить]

---

---

62/Здравствуйте уважаемые программисты. Подскажите принцип работы с объектом phone. Вопрос жизни и смерти. [Ответить]

Отвечает: Артемий
Принцип можно, Сначала подключаешь его к порту где стоит модем, поом перходишь на нужный режим тоновый или импульсный, ну а дальше набирешь номер и звонишь, в инете есть много примеров.

---

Оценка за ответ: 4

---

90/Привет всем. Нужно с помощью программы отправлять данные на веб-страницу, а именно отправить номер телефона и SMS сообщение на страницу php в Интернете. Помогите пожалуйста. [Ответить]

Отвечает: Артемий
Смотря какой скрипт написан на пхп страницы, сейчас мнокие составляют так чтобы это было не возможно сделать, есть возможность отправлять get запрос а post, у меня не получается. Вот пример по отправки смс, делал не я все координаты разработчика указаны, вероятность что mts.ru еще работает по старой схеме мала!

Option Explicit

'http://VBRussian.com
'Alexey Spirin (Alexey@VBRussian.com)


Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" _
Alias "InternetOpenUrlA" _
(ByVal hInternetSession As Long, _
ByVal lpszUrl As String, _
ByVal lpszHeaders As String, _
ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long

Private Sub cmdSend_Click()

Dim a As Long, b As Variant, Prefix As String, Message As String
Select Case cboPrefix.ListIndex
Case 0
Prefix = "7095"
Case 1
Prefix = "7910"
Case 2
Prefix = "7916"
End Select

Message = txtMessage
Message = Replace(Message, "%", "%25")
Message = Replace(Message, "?", "%3F")
Message = Replace(Message, "&", "%26")
Message = Replace(Message, vbCrLf, "%0D")

a = InternetOpen("Microsoft Internet Explorer 5.0", 0, vbNullString, vbNullString, 0)
b = InternetOpenUrl(a, "http://www.mts.ru:5051/cgi-bin/cgi.exe?function=sms_send&MMObjectType=0&MMObjectID=&To=" & Prefix & txtNumber & "&Msg=" & Message & "&Hour=23&Min=59&Day=31&Mon=12&Year=2005&Lang=2", vbNullString, 0, 0, 0)
InternetCloseHandle a
Timer1.Enabled = True
cmdSend.Enabled = False

MsgBox "Done!", vbInformation
txtNumber = ""
txtMessage = ""
cboPrefix.SetFocus

End Sub

Private Sub Form_Load()
cboPrefix.ListIndex = 2
End Sub

Private Sub Timer1_Timer()
cmdSend.Enabled = True
Timer1.Enabled = False
End Sub

Private Sub txtMessage_Change()
Label3 = "Осталось: " & 730 - Len(txtMessage)
End Sub

---

Оценка за ответ: 5

---

107/Как в Visual Basic можно создать свой элемент панели управления (*.cpl)? [Ответить]

Отвечает: Артемий
сам вб не позволят этого сделать но его возможности можно расширить для этого найди прогу Desaware SpyWorks proffesional

---

Оценка за ответ: 3

---

112/Привет. Как с помощью VB просмотреть исходный текст web страници. Как в блокноте. [Ответить]

Отвечает: Игорь
Создайте новый VB-проек. Через меню Проект/Компоненты подключите к нему 2
компонента: CommonDialog(COMDLG32.OCX) и RichTextBox(RICHTX32.OCX).
Вставьте в форму эти компоненты и 3 командные кнопки. Все имена элементов
управления оставьте по умолчанию. В свойстве элемента RichTextBox
установите значение <3-rtfBoth>. Добавьте в проект следующий
код, а все стальное будет понятно:

Option Explicit
Dim sFileName As String
Dim nFreeFile As Integer

Private Sub Command1_Click()
Rem: Открываем и загружаем файл для редактирования:
With CommonDialog1
.CancelError = False
.Filter = "Файлы HTML(*.html)|*.html|Все файлы (*.*)|*.*"
.FilterIndex = 1
.Flags = cdlOFNOverwritePrompt Or cdlOFNHideReadOnly
.FileName = Empty
.DialogTitle = "Открытие HTML файлов"
.ShowOpen
If .FileName <> vbNullString Then sFileName = .FileName
RichTextBox1.LoadFile sFileName
End With
End Sub

Private Sub Command2_Click()
Rem: Сохраняем открытый и отредактирванный файл:

nFreeFile = FreeFile

Open sFileName For Output As #nFreeFile
Print #nFreeFile, RichTextBox1.Text
Close #nFreeFile

End Sub

Private Sub Command3_Click()
Rem: Сохраняем отредактированный файл под другим имененм:
With CommonDialog1
.CancelError = False
.Filter = "Файлы HTML(*.html)|*.html|Все файлы (*.*)|*.*"
.FilterIndex = 1
.Flags = cdlOFNOverwritePrompt Or cdlOFNHideReadOnly
.FileName = Empty
.DialogTitle = "Сохранение HTML файлов"
.ShowSave
If .FileName = vbNullString Then Exit Sub
sFileName = .FileName
End With

nFreeFile = FreeFile

Open sFileName For Output As #nFreeFile
Print #nFreeFile, RichTextBox1.Text
Close #nFreeFile

End Sub

Private Sub Form_Load()
Rem: Задаем заголовки для кнопок _
Это можно делать и не программно :)

Me.Caption = "Работа с HTML файлами"
Command1.Caption = "Открыть"
Command2.Caption = "Сохранить"
Command3.Caption = "Сохранить как..."
Command1.Width = 1475: Command1.Height = 375
Command2.Width = 1475: Command2.Height = 375
Command3.Width = 1475: Command3.Height = 375
RichTextBox1.Text = vbNullString

End Sub

Private Sub Form_Resize()
Rem: Устанавливаем размеры и положение элементов _
в соответствии с изменение размеров формы:
Command1.Move 120, Me.Height - 900
Command2.Move 1680, Me.Height - 900
Command3.Move 3240, Me.Height - 900
RichTextBox1.Move 120, 120, Me.Width - 360, Me.Height - 1200
End Sub
Скачать прикрепленный файл >>>

---

Оценка за ответ: 5

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

---

Оценка за ответ: 3

Отвечает: Bourn
'Создать на форме 1 объект TExt1, поставить свойство
multiline=true, scrollbars=3
'Код формы
Dim s As String
Private Sub Form_Load()
Open "1.htm" For Binary As #1 'открываем веб страницу
1.htm для просмотра
s = String(LOF(1), 0)
Get #1, 1, s
Close
Text1.Text = s
End Sub

---

Оценка за ответ: 4

Отвечает: Stormbringer
см. исходник
Наверное это самый простой вариант.
Скачать прикрепленный файл >>>

---

Оценка за ответ: 5

---

114/Как в Visual Basic работать с архивами (сжатие, распаковка, просмотр и т.п.)? [Ответить]

Отвечает: Bourn
Вот пример: сжатия и распаковки файла на примере
ахиватора Zlib.
И пример распаковки на winrarе.
Скачать прикрепленный файл >>>

---

Оценка за ответ: 5

---

116/Здравствуйте! У меня вопрос:
Как встроить в заголовок окна кнопочку (по типу программы API-GUIDE) и
соответственно отловить события на ней? [Ответить]

Отвечает: Игорь
К сожалению ничего меньше и проще предложить не могу. Если кто-то знает,
путь поделится советом.
Создайте проект VB/ Поместите в него одну форму и один модуль.
Все о чем Вы спрашивали появится...

Код модуля формы:

Option Explicit

Private Sub Form_Load()
Me.Show
Me.ScaleMode = vbPixels 'The API works in pixels
Hook Me 'FormHook Hook()
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single,
y As Single)
If Button = 2 Then TrayMenu Me 'TrayNotify TrayMneu()
End Sub

Private Sub Form_Unload(Cancel As Integer)
UnHook 'FormHook UnHook()
End Sub


Код модуля:

Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias
"Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As
Long
Declare Function CreatePopupMenu Lib "user32" () As Long
Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal
wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long,
ByVal hwnd As Long, ByVal lprc As Any) As Long
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
Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal
dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As
String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal
nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu
As Long, ByVal hInstance As Long, lpParam As Any) As Long
Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
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
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd
As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function DrawFrameControl Lib "user32" (ByVal hdc As Long, lpRect As
RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
Declare Function GetTitleBarInfo Lib "user32" (ByVal hwnd As Long, pti As
TitleBarInfo) As Boolean
Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT,
ByVal hBrush As Long) As Long
Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As
Long
Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long,
ByVal y As Long) As Long
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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal
hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uid As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
sztip As String * 64
End Type


Const NIM_ADD = &H0
Const NIM_DELETE = &H2
Const NIM_MODIFY = &H1
Const NIF_MESSAGE = &H1
Const NIF_ICON = &H2
Const NIF_TIP = &H4

Const MF_GRAYED = &H1&
Const MF_STRING = &H0&
Const MF_SEPARATOR = &H800&
Const TPM_NONOTIFY = &H80&
Const TPM_RETURNCMD = &H100&

Public bTraySet As Boolean
Dim lMenu As Long


Const WS_EX_TOPMOST = &H8&
Const TTS_ALWAYSTIP = &H1
Const HWND_TOPMOST = -1

Const SWP_NOACTIVATE = &H10
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1

Const WM_USER = &H400
Const TTM_ADDTOOLA = (WM_USER + 4)
Const TTF_SUBCLASS = &H10

Public hWndTT As Long





Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
Integer

Public Const GWL_WNDPROC = -4

Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_MOUSEMOVE = &H200

Public Const WM_NCMOUSEMOVE = &HA0
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_NCLBUTTONUP = &HA2
Public Const WM_NCLBUTTONDBLCLK = &HA3
Public Const WM_NCRBUTTONDOWN = &HA4
Public Const WM_NCRBUTTONUP = &HA5

Public Const WM_ACTIVATE = &H6
Public Const WM_NCPAINT = &H85
Public Const WM_PAINT = &HF
Public Const WM_ACTIVATEAPP = &H1C
Public Const WM_MOUSEACTIVATE = &H21
Public Const WM_COMMAND = &H111
Public Const WM_NCACTIVATE = &H86

Public Const WM_DESTROY = &H2
Public Const WM_SIZE = &H5

Global lpPrevWndProc As Long
Global gHW As Long
Global appForm As Form


Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Type TitleBarInfo
cbSize As Long
rcTitleBar As RECT 'A RECT structure that receives the coordinates of
the title bar
rgState(5) As Long 'An array that receives a DWORD value for each
element of the title bar
End Type


Const DFC_BUTTON = 4
Const DFCS_BUTTONPUSH = &H10
Const DFCS_PUSHED = &H200

Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As
Long
Public Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As
Long, ByVal y As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As
Long

Public Type POINTAPI
x As Long
y As Long
End Type

Const SM_CXFRAME = 32

Const COLOR_BTNTEXT = 18

Dim lDC As Long
Public R As RECT

Type TOOLINFO
cbSize As Long
uFlags As Long
hwnd As Long
uid As Long
RECT As RECT
hinst As Long
lpszText As String
lParam As Long
End Type


Public Sub ButtonDraw(frm As Form, bState As Boolean)

Dim TBButtons As Integer
Dim TBarHeight As Integer
Dim TBButtonHeight As Integer
Dim TBButtonWidth As Integer
Dim DrawWidth As Integer
Dim TBI As TitleBarInfo
Dim TBIRect As RECT
Dim bRslt As Boolean
Dim WinBorder As Integer

With frm
If .Borderstyle="0" Then Exit Sub ' Don't draw a button if there is
no titlebar

'----How Many Buttons in
TitleBar------------------------------------------
If Not .ControlBox Then TBButtons = 0
If .ControlBox Then TBButtons = 1
If .ControlBox And .WhatsThisButton Then
If .BorderStyle < 4 Then
TBButtons = 2
Else
tButtons = 1
End If
End If
If .ControlBox And .MinButton And .Borderstyle="2" Then TBButtons =
3
If .ControlBox And .MinButton And .Borderstyle="5" Then TBButtons =
1
If .ControlBox And .MaxButton And .Borderstyle="2" Then TBButtons =
3
If .ControlBox And .MaxButton And .Borderstyle="5" Then TBButtons =
1

'------------------------------------------------------------------------

'----Get height of
Titlebar----------------------------------------------
'Using this method gets the height of the titlebar regardless of the
window
'style. It does, however, restrict its use to Win98/2000. So if you
want to
'use this code in Win95, then call GetSystemMetrics to find the
windowstyle
'and titlebar size.
TBI.cbSize = Len(TBI)
bRslt = GetTitleBarInfo(.hwnd, TBI)
TBIRect = TBI.rcTitleBar
TBarHeight = TBIRect.Bottom - TBIRect.Top - 1

'-----------------------------------------------------------------------

'----Get WindowBorder
Size----------------------------------------------
If .Borderstyle="2" Or .Borderstyle="5" Then
R.Top = GetSystemMetrics(32) + 2
WinBorder = R.Top - 6
Else
R.Top = 5
WinBorder = -1
End If
End With

'---------------------------------------------------------------------------

'----Use Titlebar Height to determin button
size----------------------------
TBButtonHeight = TBarHeight - 4
TBButtonWidth = TBButtonHeight + 2
'and the size and space of the dot on the button
DrawWidth = TBarHeight / 8

'---------------------------------------------------------------------------

'----Determin the position of our
button------------------------------------
R.Bottom = R.Top + TBButtonHeight

Select Case TBButtons
Case 1
R.Right = frm.ScaleWidth - (TBButtonWidth) + WinBorder
Case 2
R.Right = frm.ScaleWidth - ((TBButtonWidth * 2) + 2) + WinBorder
Case 3
R.Right = frm.ScaleWidth - ((TBButtonWidth * 3) + 2) + WinBorder
Case Else
R.Right = frm.ScaleWidth
End Select

R.Left = R.Right - TBButtonWidth

'--------------------------------------------------------------------------

'----Get the Widow DC so that we may draw in the title
bar-----------------
lDC = GetWindowDC(frm.hwnd)

'--------------------------------------------------------------------------

'----Determin the position of the
dot--------------------------------------
Dim StartXY As Integer, EndXY As Integer

Select Case TBarHeight
Case Is < 20
StartXY = DrawWidth + 1
EndXY = DrawWidth - 1
Case Else
StartXY = (DrawWidth * 2)
EndXY = DrawWidth
End Select

'--------------------------------------------------------------------------

'----We have all the information we need So Draw the
button----------------
Dim rDot As RECT
If bState Then
DrawFrameControl lDC, R, DFC_BUTTON, DFCS_BUTTONPUSH Or DFCS_PUSHED
rDot.Left = R.Right - (1 + StartXY): rDot.Top = R.Bottom - (1 +
StartXY)
rDot.Right = R.Right - (1 + EndXY): rDot.Bottom = R.Bottom - (1 +
EndXY)
Else
DrawFrameControl lDC, R, DFC_BUTTON, DFCS_BUTTONPUSH
rDot.Left = R.Right - (2 + StartXY): rDot.Top = R.Bottom - (2 +
StartXY)
rDot.Right = R.Right - (2 + EndXY): rDot.Bottom = R.Bottom - (2 +
EndXY)
End If

FillRect lDC, rDot, GetSysColorBrush(COLOR_BTNTEXT)

'---------------------------------------------------------------------------

'----Set
Tooltip------------------------------------------------------------
Dim TTRect As RECT

TTRect.Bottom = R.Bottom + (TBarHeight - ((TBarHeight * 2) + WinBorder +
5))
TTRect.Left = R.Left - (4 - WinBorder)
TTRect.Right = R.Right - (4 - WinBorder)
TTRect.Top = R.Top + (TBarHeight - ((TBarHeight * 2) + WinBorder + 5))

KillTip 'ToolTip KillTip()
CreateTip appForm.hwnd, "System Tray", TTRect 'ToolTip CreateTip()

End Sub



Private Function MakePoints(lParam As Long) As POINTAPI
Dim hexstr As String
hexstr = Right("00000000" & Hex(lParam), 8)

MakePoints.x = CLng("&H" & Right(hexstr, 4)) - (appForm.Left /
Screen.TwipsPerPixelX)
MakePoints.y = CLng("&H" & Left(hexstr, 4)) - (appForm.Top /
Screen.TwipsPerPixelY)
End Function

Public Sub Hook(frm As Form)
gHW = frm.hwnd
Set appForm = frm
lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnHook()
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub

Function WindowProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long


'---------------------------------------------------------------------------
---
'Messing around in here can cause allsorts of problems.
'So, if you must, make sure you save everytihing you want to keep
'before you run the program.
'Don't run anything outside of a message selection as it will be
'executed so many times per second that it will slow down system
response.
Dim lRslt As Long
Dim retProc As Boolean

Static STButtonState As Boolean
Static Toggle As Boolean
Static i As Integer

On Error Resume Next

Select Case uMsg

Case WM_DESTROY
TrayRestore appForm
KillTip 'ToolTip KillTip()
UnHook
retProc = True

Case WM_NCMOUSEMOVE
'Only draw the button when necessary
If GetAsyncKeyState(vbLeftButton) < 0 Then
If OverButton(lParam) Then
If Toggle = False Then
Toggle = True
ButtonDraw appForm, Toggle 'DrawButton ButtonDraw()
End If
Else
If Toggle = True Then
Toggle = False
ButtonDraw appForm, Toggle 'DrawButton ButtonDraw()
End If
End If
Else
STButtonState = False
retProc = True
End If

Case WM_NCLBUTTONDOWN
If OverButton(lParam) Then
STButtonState = True
ButtonDraw appForm, True 'DrawButton ButtonDraw()
Else
STButtonState = False
retProc = True
End If

Case WM_NCLBUTTONUP
STButtonState = False
If OverButton(lParam) Then
TraySet appForm, appForm.Caption, appForm.Icon 'TrayNotify
TraySet()
ButtonDraw appForm, False 'DrawButton ButtonDraw()
retProc = False
Else
retProc = True
End If

Case WM_LBUTTONUP
STButtonState = False
ButtonDraw appForm, False 'DrawButton ButtonDraw()
If GetAsyncKeyState(vbLeftButton) < 0 And bTraySet Then
TrayMenu appForm 'TrayNotify TrayMenu()
End If
retProc = True

Case WM_NCLBUTTONDBLCLK, WM_NCRBUTTONDOWN
If Not OverButton(lParam) Then
retProc = True
End If

Case WM_SIZE, WM_NCPAINT, WM_PAINT, WM_COMMAND
ButtonDraw appForm, False 'DrawButton ButtonDraw()
retProc = True

Case WM_ACTIVATEAPP, WM_NCACTIVATE, WM_ACTIVATE, WM_MOUSEACTIVATE
ButtonDraw appForm, False 'DrawButton ButtonDraw()
retProc = True

Case Else
retProc = True

End Select


If retProc Then
WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam,
lParam)
Else
WindowProc = 0
End If

End Function

Private Function OverButton(lParam As Long) As Boolean

Dim MP As POINTAPI

MP = MakePoints(lParam)

If PtInRect(R, MP.x, MP.y) Then OverButton = True

End Function


Public Sub CreateTip(hwndForm As Long, szText As String, rct As RECT)

hWndTT = CreateWindowEx(WS_EX_TOPMOST, "tooltips_class32", "",
TTS_ALWAYSTIP, _
0, 0, 0, 0, hwndForm, 0&, App.hInstance, 0&)

SetWindowPos hWndTT, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE

Dim TI As TOOLINFO

With TI
.cbSize = Len(TI)
.uFlags = TTF_SUBCLASS
.hwnd = hwndForm
.hinst = App.hInstance
.uid = 1&
.lpszText = szText & vbNullChar
.RECT = rct
End With

SendMessage hWndTT, TTM_ADDTOOLA, 0, TI

End Sub

Public Sub KillTip()
DestroyWindow hWndTT
End Sub

Public Sub TraySet(frm As Form, sztip As String, hIcon As Long)

Dim NID As NOTIFYICONDATA

With NID
.cbSize = Len(NID)
.hIcon = hIcon
.hwnd = frm.hwnd
.sztip = sztip & vbNullChar
.uCallbackMessage = WM_LBUTTONUP
.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
.uid = 1&
End With

Shell_NotifyIcon NIM_ADD, NID

frm.Hide
bTraySet = True

End Sub

Public Sub TrayRestore(frm As Form)

Dim NID As NOTIFYICONDATA

With NID
.cbSize = Len(NID)
.hwnd = frm.hwnd
.uid = 1&
End With

Shell_NotifyIcon NIM_DELETE, NID
frm.Show
bTraySet = False

End Sub

Public Sub TrayMenu(frm As Form)

Dim hMenu As Long, tMenu As Long
Dim MP As POINTAPI

GetCursorPos MP
hMenu = CreatePopupMenu()
If bTraySet Then
AppendMenu hMenu, MF_STRING, 1000, "Restore"
Else
AppendMenu hMenu, MF_STRING Or MF_GRAYED, 1000, "Restore"
End If
AppendMenu hMenu, MF_SEPARATOR, 0&, 0&
AppendMenu hMenu, MF_STRING, 1010, "Exit"

tMenu = TrackPopupMenu(hMenu, TPM_NONOTIFY Or TPM_RETURNCMD, MP.x, MP.y,
0&, frm.hwnd, 0&)

Select Case tMenu
Case 1000
TrayRestore frm
Case 1010
TrayRestore frm
UnHook
Unload frm
Case Else
'do nothing
End Select

DestroyMenu hMenu

End Sub
Скачать прикрепленный файл >>>

---

Оценка за ответ: 5

---

118/Как зациклить проигрывание звукового файла (*.wav) в Visual Basic? [Ответить]

Отвечает: Игорь
Option Explicit
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA"
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Rem: Некоторое параметры (далеко не все) для uFlags:
Const SND_SYNC = &H0 'синхронное воспроизведение звукового файла (по
умолчанию)
Const SND_ASYNC = &H1 'асинхронное воспроизведение звукового файла
Const SND_NODEFAULT = &H2 'если звуковой файл не найден, то не будет
воспроизводится звук по умолчанию
Const SND_FILENAME = &H20000 'имя файла
Const SND_RESOURCE = &H40004 'имя файла из файла ресурсов
Const SND_LOOP = &H8 'зацикливание воспроизведения
Const SND_NOSTOP = &H10 'не останавливать текущий файл для
воспроизведения другого

Private Sub Form_Load()
Rem: Путь к файлу можно менять программно:
sndPlaySound "C:\Windows\Media\Chimes.wav", SND_ASYNC Or SND_LOOP
End Sub

---

Оценка за ответ: 5

---

120/Как организовать взаимодействие приложений клиент-сервер на базе файловых отображений на локальном компе. Как записать данные в файловое отображение, считать сохранить на диск и т.д.? [Ответить]

Отвечает: Артемий
Я не совсем понял вопрос, Но скажу та что через винсок можно отправлять файлы. в одном из приложений размести filelist, и отправляй все записи, в другое приложение где есть скажем listbox, так ты получишь список файлов, а ясли хочешь скачать файл, то читай его как бинарный а данные отпраляй через винсок.
Ответил в крации, надеюсь основы по работе с файлами последовательного доступа, и с винсоком есть.

---

Оценка за ответ: 3

---

121/Как программно можно получить список файлов в определенной директории, разумеется, не используя FileList? Спасибо. Леха [Ответить]

Отвечает: Bourn
'Создать listbox, или то куда надо записать файлы
Dim X As Long
Dim intAttr As Integer
Dim strAllDirs As String
Dim strFile As String
On Error Resume Next
strDir = Trim$(strDir)
intAttr = GetAttr(strDir)
strFile = Dir$("*.*", vbSystem Or vbDirectory Or
vbHidden)
Do While Len(strFile)
If strFile <> "." And strFile <> ".." Then
If (intAttr And vbDirectory) Then
strAllDirs = strAllDirs & Chr$(0)
Else
List1.AddItem strFile
End If
End If
strFile = Dir$
Loop

---

Оценка за ответ: 5

Отвечает: Stormbringer
Вставь в модуль формы следующий код:

Option Explicit

Private Sub GetFileList(DirPath As String, Files() As String)
Dim DirPathTmp$
If Not Right$(DirPath, 1) = "\" Then

DirPathTmp = DirPath & "\"
Else

DirPathTmp = DirPath
End If

ReDim Files(0)
Dim Counter As Long

Dim FilePath$
FilePath = Dir(DirPathTmp & "*.*")

Do Until FilePath = vbNullString
ReDim Preserve Files(Counter)

Files(Counter) = DirPathTmp & FilePath
FilePath = Dir
Counter = Counter + 1


Loop
End Sub

Private Sub Form_Load()
Me.AutoRedraw = True
Dim F() As String
Me.Cls
GetFileList "C:\windows\рабочий стол", F()

Dim u&, l&
l = LBound(F())
u = UBound(F())
Dim c As Long
For c = l To u

Me.Print F(c)
Next
End Sub

---

Оценка за ответ: 5

---

123/Добрый день !
Как закомментировать много строк , а не каждую отдельно ?
Пример ( ' ) комментирует одну строк , а как все сразу.
'For J = 0 To 11
' FCacheServer.VisM1.P0 = cboRik & "*" & cboN.Text & "*" & i
'FCacheServer.VisM1.Value = ""
'FCacheServer.VisM1.Code = "$$WR^KAN(.P0)"
'FCacheServer.VisM1.ExecFlag = 1
'If FCacheServer.VisM1.Value = 0 Then Exit For
'If FCacheServer.VisM1.Value = "" Then Exit For
'i = PieceBasic(FCacheServer.VisM1.Value, "*", 3)
' Text(i) = PieceBasic(FCacheServer.VisM1.Value, "*", 4)
'Next J
С уважением Александр. [Ответить]

Отвечает: Игорь
По всей видимости Вы пользуетесь комментирование строк вручную. Для этого
существует специальное приспособление на панели инструментов "ToolBars".
Если она у Вас не подключена, то нажмите правой кнопки мыши по панели
инструментов и поставьте галочку напротив строки "Edit". На этой панели есть
функции "Комментировать блок" и "Раскомментировать блок". Может Вы просто не
знали для чего они нужны. Выделете определенную часть кода, которую Вы
собираетесь закомментировать и нажмите на соответсвующую кнопку. Весь
выбранный вами код будет закомментирован одним щелчком мыши. Точно также Вы
сможете затем отменить комментировку, выделив ту часть кода, которую Вам
необходимо будет раскомментировать. Если я правильно понял Ваш вопрос, то
все...

---

Оценка за ответ: 5

Отвечает: Bidgo
Выберите меню View/Toolbars/Customize. В открывшемся диалоговом окне сверху, выберите ярлык Commands. В разделе Edit найдите 2 кнопки: Comment Block и Uncomment Block. Перетащите их на свою Панель управления. С помощью этих кнопок, выделив несколько строк, одним нажатием, можно за- или раскомментировать целые блоки

---

Оценка за ответ: 5

Отвечает: Bourn
Такой функци нет, возможно использования конца
программы оператором end, тогда после него не будет
выполняться программа, но это накладывает ограничения
на использование кода в конце программы, но если
программа находиться в середине используй goto, до
начала коментария и после коментария не забудь
поставить метку.

---

Оценка за ответ: 4

Отвечает: Вячеслав
Привет
На сколько я знаю в VB как и в других диалектах Бейсика нет
многострочных комментариев, только однострочные.

---

Оценка за ответ: 4

Отвечает: Stormbringer
На панели инструментов Edit есть кнопочки:
CommentBlock - комментирует выделенный блок текста.
UnCommentBlock - разкомментирует выделенный блок текста.

---

Оценка за ответ: 5

Отвечает: Алексей
В VB вызываешь панель инструментов Text Editor []. На ней есть такая кнопочка, которая выделена на предыдущем рисунке, позволяющая комментировать целые блоки кода (предварительно их надо выделить мышью). Кнопочка справа от неё выполняет противоположное действие, то есть снимает комментарии с блоков кода. Пожалуй больше предложить нечего…

---

Оценка за ответ: 5

<Задать свой вопрос!>

Есть желание вести раздел для новичков? Отправьте заявку на Admin@visualbasic.noka.ru
Раздел в отпуске.

M означает, что данный архив содержит только модуль.

Примеры и модули Ссылка Описание Ссылка Описание about.zip Стандартное окно About в VB (4.2KB) OpenCD.zip Управление CD (M) (1KB) anigif.zip Анимация в VB (5KB) progressbar.zip Progress Bar в трее (4KB) appprioritet.zip Устанавливаем приоритет в приложении (1.8KB) randomform.zip Разные формы (M) (2KB) biosinfo.zip Просматривает ифрормацию о БИОСе (5.5KB) RandomForms.zip Разные формы (1KB) cd-rom.zip Работа с CD-ROM (1.6KB) Reestr.zip Работа с реестром (2.5KB) commondialog.zip Диалог открытия файла без контрола (1.9KB) registry.zip Регистрация в реестре (9.5KB) coolvbmenu.zip Клевое меню в VB (14KB) resource.zip Просмоторщик ресурсов проги (46.6KB) disableendtasks.zip Запрет нажатия Ctrl+Alt+Del (1.8KB) RU_EN.zip Переключение языка программно (M) (1KB) File_size.zip Определяет размер файла (M) (1KB) sharp.zip Пример часиков (2.1KB) fso.zip Работа с FSO (File System Object) (101KB) ShutDown.zip Шатдаун компьютера (M) (1KB) HDD_info.zip Информация о диске (M) (1KB) sort.zip Сортировка массива за 0.2 секунды! (M) (1KB) hddserial.zip Серийный номер диска (24KB) Standart.zip Стандартные диалоги и окна (M) (1KB) Hibernate.zip Выключение и перезагрузка ПК (M) (1KB) systrayicon.zip Иконка в трее (21KB) lines2000.zip Пример игры Lines (74KB) transparent.zip Прозрачность окна (M) (1KB) manifest.zip ХР стиль в аппликухе (2.5KB) Tray_icon2.zip Икнока в трее 2 (M) (1KB) mdlMain.zip ХР стиль в приложении (M) (1KB) Tray_icon.zip Иконка в трее (M) (1KB) winwordorfo.zip Проверка орфографии с помощью Word'а (1.9KB)

Компоненты:

Ссылка Описание Ссылка Описание SpiritButtonEdit.zip Кнопка с текстовым полем ProgBar.zip Двухцветный прогресс бар SpiritClock.zip Электронные часы RunString.zip Бегущая строка SpiritEditDate.zip Компонент редактирования даты STrayIco.zip Иконка в трее XPButton.zip Кнопка в стиле XP, Office, и др. UA_SuperTextBox.zip TextBox вмещающий более 65КБ текста SpiritProgressBar.zip Прогресс Бар в классическом стиле verticalLabel.zip Вертикальный лейбл ARFlatBttn.zip Кнопка vPlayer.zip Плейер HyperlinkAX.zip Компонент для создания гиперссылок shelllink.zip Программное создание иконки NEW!!!

Есть вопросы относительно статьи, задавайте!

Получить список запущенных процессов

Расположите на форме 2 элемента CommandButton и элемент ListBox.

ВАЖНОЕ ПРИМЕЧАНИЕ: БУДЬТЕ АККУРАТНЫ ПРИ ИСПОЛЬЗОВАНИИ ЭТОГО ПРИМЕРА
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2
Const WM_CLOSE = &H10
Const WM_QUIT = &H12
Dim CurrWnd As String
Dim ListItem As String
Dim Length As String

Sub GetTaskList()
CurrWnd = GetWindow(Me.hwnd, GW_HWNDFIRST)
Do While CurrWnd <> 0
Length = GetWindowTextLength(CurrWnd)
ListItem = Space(Length + 1)
Length = GetWindowText(CurrWnd, ListItem, Length + 1)
If Length <> 0 Then
List1.AddItem ListItem
End If
CurrWnd = GetWindow(CurrWnd, GW_HWNDNEXT)
DoEvents
Loop
End Sub

Private Sub Command1_Click()
List1.Clear
GetTaskList
End Sub

Private Sub Command2_Click()
hW = FindWindow(vbNullString, List1.Text & Chr(0))
PostMessage hW, WM_QUIT, 0, 0
End Sub

Private Sub Form_Load()
Left = (Screen.Width - Width) \ 2
Top = (Screen.Height - Height) \ 2
GetTaskList
Command1.Caption = "получить список"
Command2.Caption = "Закрыть приложение"
End Sub

http://www.delphi.int.ru - Программирование на DELPHI: Вопросы и Ответы читателей; Статьи по программированию на Delphi, других языках программирования, графике (OpenGL/DirectX); Компоненты, Пакеты, Plug-in'ы, Модули для Delphi; Исходники программ, игр; Документация и ссылки на документацию по программированию; Рассылка, в которой каждый программист найдёт что-то полезное!

http://infomania2004.webhost.ru. Этот сайт создан для того, чтобы вы могли получить интересующую вас информацию с минимальными затратами сил и времени. Если вы не нашли здесь нужной информации, оставьте заявку...">

Все о Динамо - www.DynamoMania.ru На этом сайте вы найдете все новости и интервью ВСЕХ видов спорта Динамо. Также на сайте есть таблицы всех видов спорта. Видео и Фото материалы. И все это на одном сайте - www.DinamoMania.ru Это первый и единственный сайт, который освещает все виды одного клуба.