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

Стремительно прошла неделя (даже почти две недели), работа выматывает полностью, а новые выпуски рассылки ждут своего дня! Вот и очередной выпуск рассылки. На днях один из подписчиков рассылки предложил мне корректировать поступающие вопросы. Действительно, господа, получаемые мной вопросы, оставляют желать лучшего. Никакой грамматики практически в каждом третьем письме. В некоторых письмах вообще отсутствует смысл вопроса. Это не дело! Раз уж мы задаем вопрос, то давайте будет учиться его задавать. ВВОДИМ НОВОЕ ПРАВИЛО! Я пойду на уступки подписчиков и буду по возможности корректировать вопросы, а также некоторые доводить до ума. Но все-таки есть такие вопросы, которые вообще не имеют смысла. Такие вопросы будут доводиться до ума уже самими отправителями вопроса. Если вопрос непонятен, автор, т.е. Я, отправляет заявку отправителю вопроса, чтобы он внес коррекцию в свой вопрос.

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

Также в шаблон рассылки добавлена новая функция: Оценка ответа на вопрос. Пока все это обдумывается, но думаю, что в скором времени это все реализуется.

В прошлом выпуске был пропущен вопрос № 136 (следом за 135 идет 137). Такого допустить мы не может, поэтому сегодняшние новые вопросы будут содержать вопрос под номером 136.

Плюс еще одно добавление для участников рассылки. Как известно, любой желающий читатель рассылки может прислать статью. Это приветствуется автором рассылки, а теперь и вознаграждается !!! За каждую присланную статью, участник получает 10 баллов. Это самая максимальная "расценка" рассылки. Но учтите, на каждый выпуск Вы можете прислать не более одной статьи! Если Вы присылаете больше одной статьи, остальные отсеиваются и не публикуются! Не злоупотребляйте данной возможностью! Если за период формирования рассылки было прислано несколько статей от разных авторов, автор рассылки вправе выбрать самую удачную НА ЕГО ВЗГЛЯД статью и опубликовать. Прошу без обид и разочарований. Остальные статьи будут размещены на нашем сайте http://visualbasic.noka.ru, ссылки на эти статьи будут размещены непосредственно в рассылке.

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

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

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

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

5. Если Вы присылаете некорректные вопросы, они будут рассмотрены автором и откорректированы. Вопросы, смысл которых будет не понятен, либо не найден, будут перезапрошены у отправителя вопроса.

Сайт был в очередной раз обновлен. На сайте выложено еще 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 [Ответить]

---

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

---

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

---

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

---

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

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

---

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

---

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

---

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

---

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

---

125/ Здравствуйте.
Скажите пожалуйста, что такое списки управления доступом (Access Control Lists - используется в функции GetVolumeInformation) [Ответить]

---

126/ Как можно прочитать данные с COM порта? [Ответить]

---

129/ Проблема то в том, что с оборотом нужно напечатать на сетевом принтере не
все листы, а только последний, на обороте которого печатается так называемый
"расчет рассылки", в котором указывается, сколько отпечатано экземпляров,
кто исполнял документ, кто печатал, дата печати документа и т.п. (выпускные
данные) это такое правило делопроизводства. Для этого в конце документа
вставляется разрыв страницы и на новой странице набирается или генериться
расчет рассылки. Сетевой принтер с двухсторонней печатью первые n-2 листа
выкидывает в выходной лоток, а предпоследний кладет в лоток оборотной
печати, затем его оттуда забирает и прогоняет его еще раз через блок печати,
но печатает его уже с оборотной стороны, так как лист прошел через лоток
оборотной печати. Если б я знал, как из свойств документа изъять количество
листов, то как-нибудь решил бы задачку сам и мои девушки не мучались бы с
этой проблемой.

Вопрос:

предполагаю, как можно решить, но не знаю, как реализовать. Исходные данные.

Есть сетевой принтер с возможностью двухсторонней печати. Пользователи
работают с MS Word. На печать посылаются задания из n листов. При этом листы
с 1 по n-2 должны быть напечатаны с одной стороны. Лист n-1 является
последним листом документа, а лист n оборотной стороной листа n-1.

Предполагаемое решение. По нажатию кнопки "Печать1" из переменной
"Количество листов в документе" извлекается значение и присваивается
переменной n. Если n<<2 выводится на экран сообщение "Печать с оборотом
невозможна" и производится выход из программы, если n>>2 вызывается на
исполнение функция печати, которой в параметрах передается:

1) Печатать листы с 1 по n-2;
2) Печатать без оборота.
Вызывается на исполнение функция печати, которой в параметрах передается:
1) Печатать листы n-1, n;
2) Печатать с оборотом.

При этом желательно сделать так, чтобы между вызовами функций печати в
очередь печати не проскочило какое-нибудь задание. Естественно, все это
оформить в виде макроса. Прошу Вас помочь мне>.



На Си++ получилось что-то вроде этого:

void Print1 (void) /* Эта функция связана с кнопкой "Печать1" */
{
int n; /* количество листов в документе */
n = (Извлекаем количество листов);
if (n < 2)
{
cout << "Печать с оборотом невозможна";
/* Можно вызвать функцию Worda для односторонней печати, если n >> 0 */
if (n > 0) PrintWorda (int 1, int 1, int 0);
}
if (n > 2) PrintWorda (int 1, int n-2, int 0); /* Печать без оборота */
PrintWorda (int n-1, int n, int 1); /* Печать с оборотом, в том числе для n
== 2 */
} [Ответить]

---

130/ Доброго времени суток, User`ы. Подскажите пожалуйсто, как в VB 6.0 к какому-либо устройству в порте COM по определённому адресу? Благодарю за внимание и за ответ. Спасибо. [Ответить]

---

132/ Добрый день! На вопрос "Как узнать программно(есть ли стандартные функции или нестандартные): -уровень заряда батарее в ноутбуке; -температуру жесткого диска; -температуру процессора; -скорости вентиляторов. Заранее благодарен!" я что-то не получил ответь
Тожностью как можно на text1.text = "температура" [Ответить]

---

---

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

Отвечает: Игорь
Да, действительно, Вам прошлый раз ответили, что в Нете примеров работы с
Phone просто завались, но мы не для того подписались на эту подписку, чтобы
искать в Нете то, о чем спрашиваем. Поэтому высылаю Вам <небольшой>
примерчик. Если Автор рассылки посчитает, что его размер слишком велик, то
прикрепляю его ваиант в текстовом формате отдельно и конечно же - проектик:

Создайте новый проект. Назовите его как Вам угодно, но желательно, чтобы он
отображал суть, например <MyPhone>. Подключите к проекту компонент Microsoft
Windows Common Controls 6.0 (Меню Проект/Компоненты: (MSCOMCTL.OCX)).
Измените название главной формы проекта (<Form1>) на <frmDial>. Добавьте в
проект следующие компоненты, оставив все их имена по умолчанию: 1 ComboBox,
3 TextBox, 1 CheckBox, 2 OptionButton, 2 CommandButton, 3 Label, 1
StatusBar, 1 Image и 1 Timer. Для ComboBox в свойстве <Style> желательно
установить значение <2-Dropdoun List>. Затем просто вставьте в код модуля
формы и в код модуля нижеприведенные коды.
Для полной работы Вам пригодятся коды для работы с RAS, а также с реестром
Windows. Необходимые для работы в данной программе функции прилагаются в
коде модуля.
Для полноты действия даного примера поместите в папку с проектом 3 звуковых
файла с названиями <CONNECT.WAV>, <DISCONNECT.WAV> и <START.WAV> (Хотя это
не обязательно:).

Приложение к ответу (исходный код):
КОД МОДУЛЯ ФОРМЫ: Option Explicit Private Declare Function ShellAbout Lib "shell32.dll" _ Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As _ String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long Private Sub Check1_Click() Rem: Записываем в реестре необходимость запоминать пароль: WriteInteger HKEY_CURRENT_USER, sReg, "ChPass", Check1.Value End Sub Private Sub Combo1_Click() Me.Caption = "Соединение """ & Combo1.Text & """" Rem: Заполняем данными необходимые поля (Пароль и Имя пользователя): Text1 = vbNullString Text2 = vbNullString Text3 = vbNullString Text1 = ReadString(HKEY_CURRENT_USER, sReg, Combo1.Text & "." & "UserName", vbNullString) Text2 = Decrypt(ReadString(HKEY_CURRENT_USER, sReg, Combo1.Text & "." & "Password", vbNullString), False) Text3 = ReadString(HKEY_CURRENT_USER, sReg, Combo1.Text & "." & "Phone", vbNullString) End Sub Private Sub Command1_Click() Rem: Выгружаем программу: Unload Me End Sub Private Sub Command2_Click() Rem: Кнопка дозвона будет нам служить и для прерывания связи... Select Case Command2.Caption Case "Подключиться" Rem: Сначала проверяемправильность заполненя всех необходимых данных: If Len(Text1) = 0 Then MsgBox "Введите Имя пользователя!", vbInformation + vbOKOnly, App.Title: _ Text1.SetFocus: Exit Sub If Len(Text2) = 0 Then MsgBox "Введите Пароль!", vbInformation + vbOKOnly, App.Title: _ Text2.SetFocus: Exit Sub If Len(Text3) = 0 Then MsgBox "Введите номер телефона дозвона!", vbInformation + vbOKOnly, App.Title: _ Text3.SetFocus: Exit Sub Rem: Заблокируем доступ к элементам управления: Command1.Enabled = False Combo1.Enabled = False Combo1.BackColor = vbButtonFace Text1.Enabled = False Text1.BackColor = vbButtonFace Text2.Enabled = False Text2.BackColor = vbButtonFace Text3.Enabled = False Text3.BackColor = vbButtonFace Option1.Enabled = False Option2.Enabled = False Check1.Enabled = False Rem: Меняем заголовок кнопки дозвона, _ чтобы затем этой же кнопкой можно было прервать связь Command2.Caption = "Прервать" Rem: Звоним Dim hConn As Long hConn = DialNET(Combo1.Text, Text1, Text2, Text3, Option2.Value) Case "Прервать" Rem: Прерываем связь: HangUp End Select End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Rem: Dialog About If KeyCode = 112 Then Call ShellAbout(Me.hwnd, App.Title, App.CompanyName, Me.Icon) End Sub Private Sub Form_Load() Rem: Разместим Ваши элементы на форме _ (конечно же это лучше делать вручную, а не программно): With Combo1 .Width = 3615 .Left = 1440 .Top = 240 .TabIndex = 0 End With With Label1 .Alignment = 1 .Left = 720 .Width = 2175 .Top = 1120 .Height = 315 .Caption = "Имя пользователя (Логин):" End With With Label2 .Alignment = 1 .Left = 720 .Width = 2175 .Top = 1600 .Height = 315 .Caption = "Пароль доступа:" End With With Label3 .Alignment = 1 .Left = 720 .Width = 2175 .Top = 2565 .Height = 315 .Caption = "Телефон доступа к сети:" End With With Text1 .Alignment = 2 .Left = 3120 .Height = 315 .Width = 1935 .Top = 1080 .Text = vbNullString .TabIndex = 1 End With With Text2 .Alignment = 2 .Left = 3120 .Height = 315 .Width = 1935 .Top = 1560 .Text = vbNullString .PasswordChar = "*" .TabIndex = 2 End With With Text3 .Alignment = 2 .Left = 3120 .Height = 315 .Width = 1935 .Top = 2520 .Text = vbNullString .TabIndex = 4 End With With Option1 .Left = 3120 .Width = 855 .Height = 195 .Top = 3000 .Caption = "Pulse" .Value = True .TabIndex = 5 End With With Option2 .Left = 4080 .Width = 855 .Height = 195 .Top = 3000 .Caption = "Tone" .Value = False .TabIndex = 6 End With With Command1 .Caption = "Отмена" .Cancel = True .Width = 1215 .Height = 375 .Top = 3600 .Left = 3840 .TabIndex = 8 End With With Command2 .Caption = "Подключиться" .Default = True .Width = 1695 .Height = 375 .Top = 3600 .Left = 2040 .TabIndex = 7 End With With Check1 .Left = 3120 .Height = 195 .Width = 1815 .Caption = "Запомнить пароль" .Top = 1920 .TabIndex = 3 End With With Image1 .Left = 240 .Top = 120 .Picture = Me.Icon End With With StatusBar1 .Align = 2 .Height = 375 .Panels(1).style="sbrText" .Panels(1).Alignment = sbrLeft .Panels(1).AutoSize = sbrSpring .Panels(1).Text = "OFF LINE" .Panels(1).Enabled = False End With With Timer1 .Enabled = False .Interval = 1000 End With With Me .Width = 5400 .Height = 4830 .Caption = App.Title .Left = Screen.Width / 2 - Me.Width / 2 .Top = Screen.Height / 2 - Me.Height / 2 .KeyPreview = True End With Rem: Загрузим список всех соединений в ComboBox: LoadRasEnteries Combo1 Rem: Создадим ключ в реестре. В нем будут храниться Ваши данные: CreateKey HKEY_CURRENT_USER, sReg Rem: Если ключ уже существует, то считывем из него дынные: Check1.Value = ReadInteger(HKEY_CURRENT_USER, sReg, "ChPass", False) Rem: Считываем данные тонового/импульсного набора номера из ресстра Option2.Value = ReadInteger(HKEY_CURRENT_USER, sReg, "TP", False) On Error Resume Next Combo1.Text = ReadString(HKEY_CURRENT_USER, sReg, "LastConn", Combo1.Text) MsgSound "START.WAV" End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Rem: Запретим выход из программы пока устанавливается или установлена связь: Cancel = blnConnect End Sub Private Sub Form_Unload(Cancel As Integer) Rem: Запоминаем последнее использов. соединение: WriteString HKEY_CURRENT_USER, sReg, "LastConn", Combo1.Text End Sub Private Sub Option1_Click() Rem: Сохраняем данные тонового/импульсного набора номера в ресстре WriteInteger HKEY_CURRENT_USER, sReg, "TP", Option2.Value End Sub Private Sub Option2_Click() Rem: Сохраняем данные тонового/импульсного набора номера в ресстре WriteInteger HKEY_CURRENT_USER, sReg, "TP", Option2.Value End Sub Private Sub Text1_Validate(Cancel As Boolean) Rem: Сохраняем Ваши данные в реестре WriteString HKEY_CURRENT_USER, sReg, Combo1.Text & "." & "UserName", Text1 End Sub Private Sub Text2_Validate(Cancel As Boolean) Rem: Сохраняем Ваши данные в реестре If Check1.Value = vbChecked Then WriteString HKEY_CURRENT_USER, sReg, Combo1.Text & "." & "Password", Encrypt(Text2, False) End Sub Private Sub Text3_Validate(Cancel As Boolean) Rem: Сохраняем Ваши данные в реестре WriteString HKEY_CURRENT_USER, sReg, Combo1.Text & "." & "Phone", Text3 End Sub Private Sub Timer1_Timer() Select Case IsOnline Case True Rem: Подсчет времени за ссесию: If lSessionSec = 59 Then lSessionSec = 0 lSessionMin = lSessionMin + 1 If lSessionMin = 59 Then lSessionHours = lSessionHours + 1 lSessionMin = 0 End If Else lSessionSec = lSessionSec + 1 End If StatusBar1.Panels(1).Text = "ON LINE. Длительность сессии: " & AddZero(lSessionHours, lSessionMin, lSessionSec) Case False Timer1.Enabled = False With StatusBar1.Panels(1) .Enabled = False .Text = "OFF LINE. Длительность последней сессии была: " & AddZero(lSessionHours, lSessionMin, lSessionSec) End With lSessionHours = 0: lSessionMin = 0: lSessionSec = 0 MsgSound "DISCONNECT.WAV" Call HangUp End Select End Sub КОД МОДУЛЯ: Option Explicit Public blnConnect As Boolean Private Type VBRasEntryName EntryName As String Win2000_SystemPhonebook As Boolean PhonebookPath As String End Type Private Type VBRasDialParams EntryName As String PhoneNumber As String CallbackNumber As String UserName As String Password As String Domain As String SubEntryIndex As Long RasDialFunc2CallbackId As Long End Type Private Const RAS_RASCONNSIZE As Integer = 412 Private Const RAS_MAXENTRYNAME As Integer = 256 Private Const RAS_MAXDEVICENAME As Integer = 128 Private Const RAS_MaxDeviceType = 16 Private Type RasConn dwSize As Long hRasConn As Long szEntryName(RAS_MAXENTRYNAME) As Byte szDeviceType(RAS_MaxDeviceType) As Byte szDeviceName(RAS_MAXDEVICENAME) As Byte End Type Declare Function RasEnumConnections _ Lib "rasapi32.dll" Alias "RasEnumConnectionsA" _ (lpRasconn As Any, _ lpcB As Long, _ lpcConnections As Long) As Long Private Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" _ (ByVal lpStrNull As String, ByVal lpszPhonebook As String, _ lpRasEntryName As Any, lpcB As Long, lpCEntries As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function RasGetErrorString _ Lib "rasapi32.dll" Alias "RasGetErrorStringA" _ (ByVal uErrorValue As Long, ByVal lpszErrorString As String, _ cBufSize As Long) As Long Private Declare Function FormatMessage _ Lib "kernel32" Alias "FormatMessageA" _ (ByVal dwFlags As Long, lpSource As Any, _ ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _ ByVal lpBuffer As String, ByVal nSize As Long, _ Arguments As Long) As Long Private Declare Function RasCreatePhonebookEntry _ Lib "rasapi32.dll" Alias "RasCreatePhonebookEntryA" _ (ByVal hwnd As Long, _ ByVal lpszPhonebook As String) As Long Private Declare Function RasDial _ Lib "rasapi32.dll" Alias "RasDialA" _ (lpRasDialExtensions As Any, _ ByVal lpszPhonebook As String, _ lpRasDialParams As Any, _ ByVal dwNotifierType As Long, _ ByVal hwndNotifier As Long, _ lphRasConn As Long) _ As Long Private Declare Function RasHangUp _ Lib "rasapi32.dll" Alias "RasHangUpA" _ (ByVal hRasConn As Long) As Long Private Declare Function RasGetEntryDialParams _ Lib "rasapi32.dll" Alias "RasGetEntryDialParamsA" _ (ByVal lpszPhonebook As String, _ lpRasDialParams As Any, _ blnPasswordRetrieved As Long) As Long Private Declare Function InternetGetConnectedState _ Lib "wininet" (ByRef dwFlags As Long, _ ByVal dwReserved As Long) As Long Enum RASCONNSTATE RASCS_OpenPort = 0 RASCS_PortOpened = 1 RASCS_ConnectDevice = 2 RASCS_DeviceConnected = 3 RASCS_AllDevicesConnected = 4 RASCS_Authenticate = 5 RASCS_AuthNotify = 6 RASCS_AuthRetry = 7 RASCS_AuthCallback = 8 RASCS_AuthChangePassword = 9 RASCS_AuthProject = 10 RASCS_AuthLinkSpeed = 11 RASCS_AuthAck = 12 RASCS_ReAuthenticate = 13 RASCS_Authenticated = 14 RASCS_PrepareForCallback = 15 RASCS_WaitForModemReset = 16 RASCS_WaitForCallback = 17 RASCS_Projected = 18 RASCS_StartAuthentication = 19 RASCS_CallbackComplete = 20 RASCS_LogonNetwork = 21 RASCS_SubEntryConnected = 22 RASCS_SubEntryDisconnected = 23 RASCS_Interactive = &H1000 RASCS_RetryAuthentication = &H1001 RASCS_CallbackSetByCaller = &H1002 RASCS_PasswordExpired = &H1003 RASCS_InvokeEapUI = &H1004 RASCS_Connected = &H2000 RASCS_Disconnected = &H2001 End Enum Public Const REG_SZ = 1 Public Const REG_DWORD = 4 Public Const HKEY_CURRENT_USER = &H80000001 Public Const ERROR_SUCCESS = 0 Public Const KEY_QUERY_VALUE = &H1 Public Const KEY_SET_VALUE = &H2 Public Const sReg As String = "SOFTWARE\YOUR DIALER\OPTION\" 'API-Функции для работы с реестром: Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value. Rem: Набор переменных и функций для работы со звуком: Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Private Const SND_ASYNC = &H1 ' Return immediately after the sound starts. Private Const SND_NODEFAULT = &H2 ' If the sound file is not found, do NOT play default sound. Rem: Переменные для подсчета времени работы в сети: Public lSessionHours As Long, lSessionMin As Long, lSessionSec As Long Rem: Ключ для шифровки пароля: Private Const lEncryptKey = 68475297 Public Function Decrypt(ByVal s As String, salt As Boolean) As String Rem: Функция для расшифровки пароля: Dim n As Long, i As Long, ss As String Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long On Error Resume Next Rem: Алгоритм расшифровки: n = Len(s) ss = Space(n) ReDim sn(n) As Long k1 = 11 + (lEncryptKey Mod 233): k2 = 7 + (lEncryptKey Mod 239) k3 = 5 + (lEncryptKey Mod 241): k4 = 3 + (lEncryptKey Mod 251) For i = 1 To n: sn(i) = Asc(Mid(s, i, 1)): Next For i = 1 To n - 2: sn(i) = sn(i) Xor sn(i + 2) Xor (k4 * sn(i + 1)) Mod 256: Next For i = n To 3 Step -1: sn(i) = sn(i) Xor sn(i - 2) Xor (k3 * sn(i - 1)) Mod 256: Next For i = 1 To n - 1: sn(i) = sn(i) Xor sn(i + 1) Xor (k2 * sn(i + 1)) Mod 256: Next For i = n To 2 Step -1: sn(i) = sn(i) Xor sn(i - 1) Xor (k1 * sn(i - 1)) Mod 256: Next For i = 1 To n: Mid(ss, i, 1) = Chr(sn(i)): Next i If salt Then Decrypt = Mid(ss, 3, Len(ss) - 4) Else Decrypt = ss End Function Public Function Encrypt(ByVal s As String, salt As Boolean) As String Rem: Функция для шифрования пароля: On Error Resume Next Rem: Алгоритм шифрования: Dim n As Long, i As Long, ss As String Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, t As Long Static saltvalue As String * 4 If salt Then For i = 1 To 4 t = 100 * (1 + Asc(Mid(saltvalue, i, 1))) * Rnd() * (Timer + 1) Mid(saltvalue, i, 1) = Chr(t Mod 256) Next s = Mid(saltvalue, 1, 2) & s & Mid(saltvalue, 3, 2) End If n = Len(s) ss = Space(n) ReDim sn(n) As Long k1 = 11 + (lEncryptKey Mod 233): k2 = 7 + (lEncryptKey Mod 239) k3 = 5 + (lEncryptKey Mod 241): k4 = 3 + (lEncryptKey Mod 251) For i = 1 To n: sn(i) = Asc(Mid(s, i, 1)): Next i For i = 2 To n: sn(i) = sn(i) Xor sn(i - 1) Xor ((k1 * sn(i - 1)) Mod 256): Next For i = n - 1 To 1 Step -1: sn(i) = sn(i) Xor sn(i + 1) Xor (k2 * sn(i + 1)) Mod 256: Next For i = 3 To n: sn(i) = sn(i) Xor sn(i - 2) Xor (k3 * sn(i - 1)) Mod 256: Next For i = n - 2 To 1 Step -1: sn(i) = sn(i) Xor sn(i + 2) Xor (k4 * sn(i + 1)) Mod 256: Next For i = 1 To n: Mid(ss, i, 1) = Chr(sn(i)): Next i Encrypt = ss saltvalue = Mid(ss, Len(ss) / 2, 4) End Function Public Function AddZero(intHours As Long, intMinutes As Long, intSeconds As Long) As String On Error Resume Next Rem: adding zeros in the time Dim sSeconds As String, sMinutes As String, sHours As String sSeconds = CStr(intSeconds) sMinutes = CStr(intMinutes) sHours = CStr(intHours) If Len(sSeconds) = 1 Then sSeconds = "0" & sSeconds End If If Len(sMinutes) = 1 Then sMinutes = "0" & sMinutes End If If Len(sHours) = 1 Then sHours = "0" & sHours End If AddZero = sHours & ":" & sMinutes & ":" & sSeconds End Function Public Sub MsgSound(SoundName As String) Rem: Процедура для воспроизвеедения звукового файла: sndPlaySound SoundName, SND_ASYNC Or SND_NODEFAULT End Sub Private Function VBRasGetAllEntries(clsRasEntryName() As VBRasEntryName, _ Optional strPhonebook As String) As Long Dim rtn As Long, i As Long Dim lpcB As Long 'count of bytes Dim lpCEntries As Long 'count of entries Dim b() As Byte Dim strTemp As String Dim dwSize As Long 'size of each entry Dim lngLen As Long Dim lngBLen As Variant ReDim b(3) 'determine appropiate size for b() lngBLen = Array(532&, 264&, 28&) For i = 0 To 2 CopyMemory b(0), CLng(lngBLen(i)), 4 rtn = RasEnumEntries(vbNullString, strPhonebook, _ b(0), lpcB, lpCEntries) If rtn <> 632 Then Exit For Next i VBRasGetAllEntries = lpCEntries If lpCEntries = 0 Then Exit Function dwSize = lpcB \ lpCEntries ReDim b(lpcB - 1) CopyMemory b(0), dwSize, 4 rtn = RasEnumEntries(vbNullString, strPhonebook, _ b(0), lpcB, lpCEntries) If rtn <> 0 Then MsgBox VBRASErrorHandler(rtn) strTemp = String(dwSize - 4, 0) ReDim clsRasEntryName(lpCEntries - 1) If dwSize = 28 Then lngLen = 21 Else lngLen = 257 For i = 0 To lpCEntries - 1 CopyMemory ByVal strTemp, b((i * dwSize) + 4), lngLen clsRasEntryName(i).EntryName = _ Left(strTemp, InStr(strTemp, Chr$(0)) - 1) Next i If dwSize > 264 Then For i = 0 To lpCEntries - 1 CopyMemory clsRasEntryName(i).Win2000_SystemPhonebook, _ b((i * dwSize) + 264), 2& CopyMemory ByVal strTemp, b((i * dwSize) + 268), 260& clsRasEntryName(i).PhonebookPath = _ Left(strTemp, InStr(strTemp, Chr$(0)) - 1) Next i Else For i = 0 To lpCEntries - 1 clsRasEntryName(i).PhonebookPath = strPhonebook Next i End If End Function Function VBRASErrorHandler(rtn As Long) As String Dim strError As String, i As Long strError = String(512, 0) If rtn > 600 Then RasGetErrorString rtn, strError, 512& Else FormatMessage &H1000, ByVal 0&, rtn, 0&, strError, 512, ByVal 0& End If i = InStr(strError, Chr$(0)) If i > 1 Then VBRASErrorHandler = Left$(strError, i - 1) End Function Public Sub HangUp() Rem: Процедура прерывания связи: Dim i As Long Dim lpRasconn(255) As RasConn Dim lpcB As Long Dim lpcConnections As Long Dim hRasConn As Long Dim rtn As Long Dim gstrISPName As String lpRasconn(0).dwSize = RAS_RASCONNSIZE lpcB = RAS_MAXENTRYNAME * lpRasconn(0).dwSize lpcConnections = 0 rtn = RasEnumConnections(lpRasconn(0), lpcB, lpcConnections) If rtn = ERROR_SUCCESS Then For i = 0 To lpcConnections - 1 If Trim(ByteToString(lpRasconn(i).szEntryName)) = Trim(gstrISPName) Then hRasConn = lpRasconn(i).hRasConn rtn = RasHangUp(ByVal hRasConn) End If Next i End If With frmDial .Command2.Caption = "Подключиться" Rem: Разблокируем доступ к элементам управления: .Command1.Enabled = True .Combo1.Enabled = True .Combo1.BackColor = vbWindowBackground .Text1.Enabled = True .Text1.BackColor = vbWindowBackground .Text2.Enabled = True .Text2.BackColor = vbWindowBackground .Text3.Enabled = True .Text3.BackColor = vbWindowBackground .Option1.Enabled = True .Option2.Enabled = True .Check1.Enabled = True .StatusBar1.Panels(1).Enabled = False End With Rem: Разрешим выход из программы: blnConnect = False End Sub Public Function DialNET(sEntryName As String, sUserName As String, sPassword As String, sPhone As String, TP As Boolean) As Long Dim rtn As Long Dim b() As Byte Dim myDialParams As VBRasDialParams Dim lngHConn As Long Dim strPhonebook As String With myDialParams .EntryName = sEntryName .UserName = sUserName .Password = sPassword If TP = False Then .PhoneNumber = "P" & sPhone Else .PhoneNumber = sPhone End If .CallbackNumber = "*" 'Устанавливается свойством соединения .Domain = "*" 'Устанавливается свойством соединения End With rtn = VBRasDialParamsToBytes(myDialParams, b) rtn = RasDial(ByVal 0&, strPhonebook, b(0), _ 1&, AddressOf RasDialFunc1, lngHConn) 'todo: check if rtn = 0 else handle error DialNET = lngHConn Rem: Запретим выход из программы пока устанавливается или установлена связь: blnConnect = True End Function Private Sub RasDialFunc1(ByVal hRasConn As Long, ByVal unMsg As Long, _ ByVal rasConnectionState As Long, ByVal dwError As Long, _ ByVal dwExtendedError As Long) With frmDial.StatusBar1.Panels(1) Select Case rasConnectionState Case RASCS_OpenPort .Text = "Открытие порта..." Case RASCS_PortOpened .Text = "Порт открыт..." Case RASCS_ConnectDevice .Text = "Звоним по номеру " & frmDial.Text3 & "..." Case RASCS_DeviceConnected .Text = "Успешно связались с провайдером..." Case RASCS_Authenticate .Text = "Проверка имени пользователя и пароля..." Case RASCS_AuthNotify .Text = "Аутинтификация прошла успешно..." Case RASCS_AuthRetry .Text = "Имя пользователя или пароль не определены:" Case RASCS_AuthProject .Text = "The projection phase is starting..." Case RASCS_AuthLinkSpeed .Text = "The link-speed calculation phase is starting..." Case RASCS_AuthAck .Text = "Аутинтификация пройдена успешно..." Case RASCS_ReAuthenticate .Text = "Повторная проверка имени пользователя и пароля..." Case RASCS_Authenticated .Text = "Аутинтификация пройдена успешно..." Case RASCS_PrepareForCallback .Text = "Подготовка к обратному вызову..." Case RASCS_WaitForCallback .Text = "Ожидание обратного вызова..." Case RASCS_Projected .Text = "Projection result information is available..." Case RASCS_CallbackComplete .Text = "Соединение будет осуществляться с использование Callback..." Case RASCS_LogonNetwork .Text = "Вход в сеть..." Case RASCS_SubEntryConnected .Text = "Subentry has been connected during the dialing process" Case RASCS_SubEntryDisconnected .Text = "Subentry has been disconnected during the dialing process" Case RASCS_Interactive .Text = "Terminal state supported by RASPHONE.EXE..." Case RASCS_RetryAuthentication .Text = "Retry authentication state supported by RASPHONE.EXE..." Case RASCS_CallbackSetByCaller .Text = "Callback state supported by RASPHONE.EXE..." Case RASCS_PasswordExpired .Text = "Change password state supported by RASPHONE.EXE..." Case RASCS_InvokeEapUI .Text = "STRING_InvokeEapUI" Case RASCS_Connected .Enabled = True .Text = "ON LINE" frmDial.Timer1.Enabled = True MsgSound "CONNECT.WAV" Case RASCS_Disconnected .Text = "Ошибка " & Str(dwError) & ": " & VBRASErrorHandler(dwError) Call HangUp End Select End With Debug.Print rasConnectionState End Sub Public Function IsOnline() As Boolean Rem: Функция вернёт True если присутствует соединие с интернетом любого типа IsOnline = InternetGetConnectedState(0&, 0&) End Function Function VBRasGetEntryDialParams _ (bytesOut() As Byte, _ strPhonebook As String, strEntryName As String, _ Optional blnPasswordRetrieved As Boolean) As Long Dim rtn As Long Dim blnPsswrd As Long Dim bLens As Variant Dim lngLen As Long, i As Long bLens = Array(1060&, 1052&, 816&) 'try our three different sizes for RasDialParams For i = 0 To 2 lngLen = bLens(i) ReDim bytesOut(lngLen - 1) CopyMemory bytesOut(0), lngLen, 4 If lngLen = 816& Then CopyStringToByte bytesOut(4), strEntryName, 20 Else CopyStringToByte bytesOut(4), strEntryName, 256 End If rtn = RasGetEntryDialParams(strPhonebook, bytesOut(0), blnPsswrd) If rtn = 0 Then Exit For Next i blnPasswordRetrieved = blnPsswrd VBRasGetEntryDialParams = rtn End Function Public Function LoadRasEnteries(Combo As ComboBox) Rem: Функция для загрузки всех имеющихся соединений на компьютере _ в определенный ComboBox: Dim myEntries() As VBRasEntryName Dim lngCount As Long lngCount = VBRasGetAllEntries(myEntries) If lngCount = 0 Then Rem: Если на компьютере нет созданных соединений, _ то повится диалог создания Нового соединения, а программа завершится... Call RasCreatePhonebookEntry(frmDial.hwnd, vbNullString) End Else Dim Counter As Long For Counter = 0 To lngCount - 1 Combo.AddItem myEntries(Counter).EntryName Next Counter Combo.ListIndex = 0 End If End Function Sub CopyByteToTrimmedString(strToCopyTo As String, _ bPos As Byte, lngMaxLen As Long) Dim strTemp As String, lngLen As Long strTemp = String(lngMaxLen + 1, 0) CopyMemory ByVal strTemp, bPos, lngMaxLen lngLen = InStr(strTemp, Chr$(0)) - 1 strToCopyTo = Left$(strTemp, lngLen) End Sub Sub CopyStringToByte(bPos As Byte, _ strToCopy As String, lngMaxLen As Long) Dim lngLen As Long lngLen = Len(strToCopy) If lngLen = 0 Then Exit Sub ElseIf lngLen > lngMaxLen Then lngLen = lngMaxLen End If CopyMemory bPos, ByVal strToCopy, lngLen End Sub Function VBRasDialParamsToBytes( _ udtVBRasDialParamsIN As VBRasDialParams, _ bytesOut() As Byte) As Boolean Dim rtn As Long Dim blnPsswrd As Long Dim b() As Byte Dim bLens As Variant Dim dwSize As Long, i As Long Dim iPos As Long, lngLen As Long bLens = Array(1060&, 1052&, 816&) For i = 0 To 2 dwSize = bLens(i) ReDim b(dwSize - 1) CopyMemory b(0), dwSize, 4 rtn = RasGetEntryDialParams(vbNullString, b(0), blnPsswrd) If rtn = 623& Then Exit For Next i If rtn <> 623& Then Exit Function On Error GoTo badBytes ReDim bytesOut(dwSize - 1) CopyMemory bytesOut(0), dwSize, 4 If dwSize = 816& Then lngLen = 21& ElseIf dwSize = 1060& Or dwSize = 1052& Then lngLen = 257& Else 'unkown size Exit Function End If iPos = 4 With udtVBRasDialParamsIN CopyStringToByte bytesOut(iPos), .EntryName, lngLen iPos = iPos + lngLen: lngLen = 129 CopyStringToByte bytesOut(iPos), .PhoneNumber, lngLen iPos = iPos + lngLen: lngLen = 129 CopyStringToByte bytesOut(iPos), .CallbackNumber, lngLen iPos = iPos + lngLen: lngLen = 257 CopyStringToByte bytesOut(iPos), .UserName, lngLen iPos = iPos + lngLen: lngLen = 257 CopyStringToByte bytesOut(iPos), .Password, lngLen iPos = iPos + lngLen: lngLen = 16 CopyStringToByte bytesOut(iPos), .Domain, lngLen If dwSize > 1052& Then CopyMemory bytesOut(1052), .SubEntryIndex, 4& CopyMemory bytesOut(1056), .RasDialFunc2CallbackId, 4& End If End With VBRasDialParamsToBytes = True Exit Function badBytes: 'error handling goes here ?? VBRasDialParamsToBytes = False End Function Private Function ByteToString(bytString() As Byte) As String Dim i As Integer ByteToString = "" i = 0 While bytString(i) = 0& ByteToString = ByteToString & Chr(bytString(i)) i = i + 1 Wend End Function Public Sub CreateKey(ByVal lRootKey As Long, ByVal sKeyName As String) 'Создает новый ключ в реестре: On Error Resume Next Dim hKey As Long Call RegCreateKey(lRootKey, sKeyName, hKey) RegCloseKey (hKey) End Sub Public Sub WriteString(ByVal lRootKey As Long, ByVal sPath As String, ByVal sValueName As String, sValueData As String) 'Функция записи в реестр СТРОКОВОГО параметра: On Error Resume Next Dim hKey As Long, lResult As Long lResult = RegOpenKeyEx(lRootKey, sPath, vbNull, KEY_SET_VALUE, hKey) If lResult = ERROR_SUCCESS Then sValueData = sValueData & Chr(0) Call RegSetValueEx(hKey, sValueName, vbNull, REG_SZ, ByVal sValueData, Len(sValueData)) Call RegCloseKey(hKey) End If End Sub Public Function ReadString(ByVal lRootKey As Long, ByVal sPath As String, ByVal sValueName As String, ByRef sDefault As String) As String Rem: 'Функция чтения из реестра СТРОКОВОГО параметра: On Error Resume Next Dim hKey As Long, lResult As Long, lValueType As Long, lDataBufSize As Long, strBuf As String lResult = RegOpenKeyEx(lRootKey, sPath, 0, KEY_QUERY_VALUE, hKey) If lResult = ERROR_SUCCESS Then lResult = RegQueryValueEx(hKey, sValueName, vbNull, lValueType, ByVal 0&, lDataBufSize) If lValueType = REG_SZ Then strBuf = Space$(lDataBufSize) lResult = RegQueryValueEx(hKey, sValueName, vbNull, REG_SZ, ByVal strBuf, lDataBufSize) If lResult = ERROR_SUCCESS Then ReadString = ClearNulls(strBuf) Else ReadString = sDefault End If Else ReadString = sDefault End If End If Call RegCloseKey(hKey) End Function Public Sub WriteInteger(ByVal lRootKey As Long, ByVal sPath As String, ByVal sValueName As String, ByVal iValue As Integer) 'Функция записи в реестр ЧИСЛОВОГО значения типа INTEGER: On Error Resume Next Dim hKey As Long, lResult As Long lResult = RegOpenKeyEx(lRootKey, sPath, vbNull, KEY_SET_VALUE, hKey) If lResult = ERROR_SUCCESS Then Call RegSetValueEx(hKey, sValueName, vbNull, REG_DWORD, CLng(iValue), 4) Call RegCloseKey(hKey) End If End Sub Public Function ReadInteger(ByVal lRootKey As Long, ByVal sPath As String, ByVal sValueName As String, iDefault As Integer) As Integer 'Функция чтения из реестра ЧИСЛОВОГО значения типа INTEGER: On Error Resume Next Dim hKey As Long, lResult As Long, lValueType As Long, lData As Long lResult = RegOpenKeyEx(lRootKey, sPath, 0, KEY_QUERY_VALUE, hKey) If lResult = ERROR_SUCCESS Then lResult = RegQueryValueEx(hKey, sValueName, 0&, lValueType, lData, LenB(lData)) If lResult = ERROR_SUCCESS And lValueType = REG_DWORD Then ReadInteger = CInt(lData) Else ReadInteger = iDefault End If Call RegCloseKey(hKey) Else ReadInteger = iDefault End If End Function Public Function ClearNulls(ByVal strSource As String) As String 'Очистка от нулей: On Error Resume Next Dim iPos As Integer iPos = InStr(strSource, Chr$(0)) If iPos <> 0 Then ClearNulls = Left$(strSource, iPos - 1) End If End Function
Скачать прикрепленный файл >>>

---

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

---

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

Отвечает: EnzO)Stalker
Если я правильно понял, то все как всегда просто:

Создаешь форму, на ней размещаешь кнопку Command1. Дальше пишешь:

Private Sub Command1_Click()

Dim dTaskID As Double
dTaskID = Shell("c:\Programm Files\MS Query.exe")

End Sub

---

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

---

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

Отвечает: Oleg K.
Сама процедура записи проста и сводится всего к одной инструкции:

Приложение к ответу (исходный код):
' Сохранение открытой книги в файл формата dBASE-III в директорию ' "C:\Мои документы\" под именем test.dbf ' Sub Макрос1() ActiveWorkbook.SaveAs Filename:="C:\Мои документы\test.dbf", _ FileFormat:=xlDBF3, CreateBackup:=False End Sub ================= Но перед этим файл нужно СПЕЦИАЛЬНО ГОТОВИТЬ. И тут, не зная требуемой спецификации DBF, можно дать только общие рекомендации. Например: 1) Нужно установить фиксированную ширину столбцов для полей базы данных. Т.е. если в спецификации DBF у такого то поля стоит C:30 (символьное 30-знаков), то нужно выделить этот столбец и установить ширину столбца равную 30. Вот программный код для первого столбца ... Columns("A:A").Select Selection.ColumnWidth = 30 ... 2) нужно для числовых полей жестко установить числовой формат с фиксированным числом десятичных знаков (если оставить общий формат, то число вероятнее всего будет округлено, и может вовсе потерять дробную часть). 3) Надо прописать в первую строку заголовки полей согласно синтаксису dBASE. Кроме того, не следует забывать, что сохранить можно только один лист. В общем достаточно нужно поработать "ДО ТОГО КАК". В противном случае, результат подобного сохранения будет непредсказуем и вряд ли Вас порадует.

---

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

---

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

Отвечает: Игорь
1) Если Вы пользуетесь для дозвона MSComm 6.0, то, возможно, Вам будет
полезна функция:

Приложение к ответу (исходный код):
Declare Function GetCommState _ Lib "kernel32" _ (ByVal nCid As Long, _ lpDCB As DCB) As Long Не буду тратить время, расписывая пример ее использования, т.к. не знаю точно, чем Вы дозваниваетесь по модему: 2) На счет проигрывания звукового файла, посмотрите в двух предыдущих выпусках расслыки (# 38-39) - там полно примеров по этому поводу.

---

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

---

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

Отвечает: Игорь
А разве у WinSock нет события DataArrival?

Приложение к ответу (исходный код):
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) Rem: С получением первых байтов происходит событие написанное ниже, _ bytesTotal - размер файла, а Winsock1.BytesReceived - сколько уже пришло! Me.Caption = "Осталось " & bytesTotal - Winsock1.BytesReceived If Winsock1.BytesReceived = bytesTotal Then MsgBox "Файл закачался полностью." End Sub Если Вы действительно работаете над закачкой файлов с ftp через winsock, то, возможно я что-то не то Вам подсказываю, хотя понятие "работаю" растяжимое

---

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

---

124/Помогите пожалуйста,
1. как через ADO программно подключиться к базе данных dbase III и Visual FoxPro
2. как скоприовать данные из базы dbase III в базу данных Visual FoxPro,
структуры этих баз одинаковые, т.е. из s_052005.dbf в Reg_s.dbf
примерчик бы не помешал [Ответить]

Отвечает: Игорь
Возможно, так:
Data1.Connect = "dBASE III" (или "FoxPro 3.0")
Data1.DatabaseName = strPath
Data1.RecordSource = strSource

где strPath - полный путь к базе данных (например, "C:\Temp\db.mdb");
strSource - ресурс (например, "Лист1$")

---

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


Отвечает: Sergey Strizhakov
Я бы посоветовал при помощи SQL запросов всё это сделать, я так
формировал новый дбф файл
Скачать прикрепленный файл >>>

---

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

---

127/ Привет! Как открыть окно и затормозить процесс вызвавший его (одним действием) как в элементе CommonDialog(.ShowOpen) или соответствующих API. [Ответить]

Отвечает: Игорь
Я так понимаю, что Вы желаете открыть какое-либо окно (форму) и затормозить
действия, идущие за процедурой открытия окна (формы) до его (её) закрытия.
Если я Вас правильно понял, то для этого необходимо открыть окно (форму)
модально, т.е.: Form2.Show vbModal. Все процессы, написанные в коде за этой
процедурой не будут выполняться пока форма Form2 будет оставаться
загруженой, а после ее закрытия начнется выполнение последующих задач.
Например, создайте проект из двух форм (Form1 и Form2). На первую форму
поместите кнопку (Command1). Добавьте следующий код:

Private Sub Command1_Click()
Form2.Show vbModal
MsgBox <>
End Sub

При нажатии на кнопку загрузится вторая форма (Form2), но сообщение MsgBox
не появится, пока форма не закроется. Если же не написать vbModal, то и
вторая форма и сообщение MsgBox появятся одновременно:

---

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

---

128/Привет! Как узнать размер файла в интернете не скачивая его(если это возможно) [Ответить]

Отвечает: Игорь
онечно возможно! Для этого можно воспользоваться библиотекой WININET.DLL,
которая является частью Win32 API. Но зачем морочить голову, если за Вас это
сделали другие? Начиная с 5-й версии Visual Basic, в него входит специальный
ActivX компонент Microsoft Internet Transfer Control, который фактически
является интерфейсом к основной библиотеке Windows WININET.DLL. Он
обеспечивает поддержку нескольких стандартных протоколов, в том числе FTP и
HTTP. Протокол FTP имеет больше возможностей, но HTTP, как считают
специалисты, обладает большей гибкостью в использовании. Итак, все, что Вам
необходимо - это подключить Internet Transfer Control в Ваш проект (Меню
Проект/Компоненты).

Существует два метода, используемых для получения файлов: синхронный и
асинхронный.

Синхронный метод. Команда OpenURL используется чтобы получить доступ к
документу в Internet и помещает его копию на локальном компьютере. Все, что
Вы должны определить - URL документа, который Вм требуется, а также его
тип - icString для текстовых файлов или icByteArray для бинарных файлов
(программ, архивов и т.п.)

Приложение к ответу (исходный код):
Использование: Dim vData as Variant vData = Inet1.OpenURL("http://www:.. короче, URL документа", icString) После того, как файл получен, Вы можете сохранить его на локальном компьютере: Open "C:/Index.html" For Output As #1 Print #1, ,vData Close #1 Метод OpenURL выполняется синхронно, т.е. управление в Вашу программу будет передано только тогда, когда передача запрашиваемого файла будет завершена. Для того, чтобы выполнение программы не прерывалось, существует способ асинхронной передачи файлов - метод Execute. В настоящее время одкументированы следующие команды для HTTP серверов: GET - прием файла с сервера; HEAD - прием заголовка, что в Впашем случае и необходимо; POST - альтернативный метод приема данных; PUT - передача файлов на сервер. После того, как Вы открыти файл методом OpenURL, Вам становятся доступны некоторые его свойства: Итак, допустим Вам необходимо узнать размер документа. Для этого используйте такой код: sLenth = Inet1.GetHeader("Content-length") Метод GetHeader можно использовать только после принятия заголовка или открытия документа методом OpenURL. Поэтому необходимо сначала узнать его заголовок. Если Вм необходимо принять только заголовок документа, то воспользуйтесь следующим кодом: Inet1.Execute, "HEAD" Do If Not Inet1.StillExecuting Then Exit Do DoEvents Loop sLenth = Inet1.GetHeader("Content-length") Ближе к делу: Создайте новый проект. Подключите к нему (Меню Проект/Компоненты) Microsoft Internet Transfer Control 6.0 (MSINET.OCX) и Microsoft Windows Common Controls 6.0 (MSCOMCTL.OCX). Добавьте в проект следующие элементы управления, не меняя их имен по умолчанию (желательно в той же последовательности): 1 Frame, 1 TextBox, 1 CommandButton, 12 Label и из подключенных компонентов по одному экземпляру - Inet и StatusBar. Задайте заголовок для Вашего проекта и вставьте в модуль формы нижеприведенный код. После того как Вы введете URL адрес документа и нажмете на кнопку <Download INFO> произойдет подключение к серверу и Вы получите такие данные за выбраный Вами файл в сети: 1. Время и дата передачи документа на сервер; 2. Версию протокола MIME; 3. Название сервера: 4. РАЗМЕР ДОКУМЕНТА В БАЙТАХ; 5. MIME Тип даных; 6. Дату и время последней модификации документа. P.S: Не все даные могут быть доступны. В том числе и размер документа может быть искажен, если введеный Вами файл является ASP или каким-либо другим динамически формируемым, т.к. получить размер еще не существующего документа невозможно. Кнопка Esc очистит все поля для возможности получить INFO для следующего файла. Желаю удачи! КОД МОДУЛЯ ФОРМЫ: Option Explicit Private Sub Command1_Click() Rem: Проверим чтобы строка URL не была пустой: If Len(Text1) = 0 Then MsgBox "Введите URL адрес документа!", 48 + 0, App.Title: Text1.SetFocus: Exit Sub Rem: Можем автоматически вставлять "http", как это делаеся везде... If Mid(Text1, 1, 7) <> "http://" Then Text1 = "http://" & Text1 Text1.Enabled = False Command1.Enabled = False Rem: Открываем URL: Dim vData As Variant vData = Inet1.OpenURL(Text1.Text, icByteArray) Inet1.Execute , "GET" 'Здесь и указывается тип скачивания Do If Not Inet1.StillExecuting Then Exit Do DoEvents Loop End Sub Private Sub Inet1_StateChanged(ByVal State As Integer) Rem: Пишем в статусной строке состояние Статус Inet StatusBar1.SimpleText = GetConnectionState(State) Select Case State Rem: Здесь можно обрабатывать и другие события Case icResponseCompleted Rem: Заполняем необходимые поля на форме: Dim s As String s = Inet1.GetHeader("Date") If Len(s) > 0 Then Label1.Caption = s: Label7.Enabled = True s = Inet1.GetHeader("MIME-version") If Len(s) > 0 Then Label2.Caption = s: Label8.Enabled = True s = Inet1.GetHeader("Server") If Len(s) > 0 Then Label3.Caption = s: Label9.Enabled = True s = CStr(Inet1.GetHeader("Content-length")) If Len(s) > 0 Then Label4.Caption = s: Label10.Enabled = True s = Inet1.GetHeader("Content-type") If Len(s) > 0 Then Label5.Caption = s: Label11.Enabled = True s = Inet1.GetHeader("Last-modified") If Len(s) > 0 Then Label6.Caption = s: Label12.Enabled = True Rem: Отключаемся от сервера, но можем сюда вставить и закачку файла... Inet1.Cancel End Select End Sub Private Function GetConnectionState(intState As Integer) As String Rem: Функция для вывода информации о состоянии Inet Select Case intState Case 0 GetConnectionState = "Информация о состоянии не доступна." Case 1 GetConnectionState = "Поиск IP адреса сервера..." Case 2 GetConnectionState = "IP адрес сервера найден..." Case 3 GetConnectionState = "Соединение с сервером..." Case 4 GetConnectionState = "Соединился с сервером..." Case 5 GetConnectionState = "Запрос информации с сервера..." Case 6 GetConnectionState = "Запрос на сервер успешно отправлен..." Case 7 GetConnectionState = "Получение ответа с сервера..." Case 8 GetConnectionState = "Ответ с сервера был успешно получен..." Case 9 GetConnectionState = "Отключение от сервера..." Case 10 GetConnectionState = "Отключение от сервера выполнено." Case 11 GetConnectionState = "Произошла ошибка во время сеанса связи." Text1.Enabled = True Command1.Enabled = True Case 12 GetConnectionState = "Запрос выполнен, все данные получены." End Select End Function Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Rem: Кнопка Esc будет очищать данные: If KeyCode = 27 Then Label1.Caption = vbNullString Label2.Caption = vbNullString Label3.Caption = vbNullString Label4.Caption = vbNullString Label5.Caption = vbNullString Label6.Caption = vbNullString Label7.Enabled = False Label8.Enabled = False Label9.Enabled = False Label10.Enabled = False Label11.Enabled = False Label12.Enabled = False Inet1.Cancel Command1.Enabled = True StatusBar1.SimpleText = "Введите URL адрес документа в текстовое поле и нажмите кнопку ""Download INFO""" With Text1 .Text = vbNullString .Enabled = True .SetFocus End With End If End Sub Private Sub Form_Load() With Label1 .Top = 1320 .Left = 4200 .Width = 3975 .Height = 255 .Caption = vbNullString End With With Label2 .Top = 1680 .Left = 4200 .Width = 3975 .Height = 255 .Caption = vbNullString End With With Label3 .Top = 2040 .Left = 4200 .Width = 3975 .Height = 255 .Caption = vbNullString End With With Label4 .Top = 2385 .Left = 4200 .Width = 3975 .Height = 255 .Caption = vbNullString End With With Label5 .Top = 2745 .Left = 4200 .Width = 3975 .Height = 255 .Caption = vbNullString End With With Label6 .Top = 3105 .Left = 4200 .Width = 3975 .Height = 255 .Caption = vbNullString End With With Label7 .Top = 1320 .Left = 120 .Width = 3975 .Height = 255 .Enabled = False .Caption = "Время и дата передачи документа:" End With With Label8 .Top = 1680 .Left = 120 .Width = 3975 .Height = 255 .Enabled = False .Caption = "Версия протокола MIME:" End With With Label9 .Top = 2040 .Left = 120 .Width = 3975 .Height = 255 .Enabled = False .Caption = "Имя сервера:" End With With Label10 .Top = 2385 .Left = 120 .Width = 3975 .Height = 255 .Enabled = False .Caption = "Размер документа в байтах:" End With With Label11 .Top = 2745 .Left = 120 .Width = 3975 .Height = 255 .Enabled = False .Caption = "Тип данных MIME:" End With With Label12 .Top = 3105 .Left = 120 .Width = 3975 .Height = 255 .Enabled = False .Caption = "Дата и время последней модификации документа:" End With With StatusBar1 .style="sbrSimple" .SimpleText = "Введите URL адрес документа в текстовое поле и нажмите кнопку ""Download INFO""" .Align = 2 .Height = 325 End With With Text1 .Top = 510 .Height = 315 .Text = vbNullString .Width = 5895 .Left = 240 .TabIndex = 0 End With With Command1 .Left = 6240 .Top = 480 .Width = 1455 .Height = 375 .Caption = "Download INFO" .Default = True .TabIndex = 1 End With With Frame1 .Top = 120 .Left = 120 .Width = 7695 .Height = 975 .Caption = "URL адрес документа" End With With Inet1 .Protocol = icHTTP End With With Me .Caption = App.Title .KeyPreview = True .Width = 8010 .Height = 4425 End With End Sub
Скачать прикрепленный файл >>>

---

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

---

131/Как-то я видел в сети программу для защиты баз данных Access от нажатия клавишы Shift. Был бы благодарен за исходный код или ссылку на подобную программу. [Ответить]

Отвечает: ElenaB_
См. MSDN
Microsoft Access 2000 Technical Articles Setting Startup Options Programmatically in Access 2000

http://msdn.microsoft.com/library/en-us/dnacc2k/html/acstartupoptions.asp

а также

Chapter 2: Protecting Your Database with Startup Options
http://msdn.microsoft.com/library/en-us/dndbdes/html/CHAPTER2AccessProtectionSecurity.asp

Примечание автора рассылки: ссылки на узел Microsoft.com не являются рекламой.

---

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

---

133/Как скачать страницу PhP
Беру ссылку с главной страницы сайта
Проблема в том что в броузере адрес который был на предыдущей странице изменяется! Откуда броузер берет новый адрес? [Ответить]

Отвечает: Игорь
Полный ответ на Ваш вопрос Вы сможете найти, скачав пример к ответу # 128
(5,38 КБ). Там я отвечал по поводу вычисления размера файла в Интернете, не
скачивая его, но пример, который я добавил к своему ответу, содержит и
скачивание файла из Интернета, используя Microsoft Internet Transfer
Control, что относится не только к файлам, а и к страницам html, php, shtml
и др. Пример снабжен комментариями; думаю, что, скачав его, все станет ясно.

Если лень качать пример, то ...
:Создайте новый проект и подключите к нему компонент Microsoft Internet
Transfer Control. Вставьте на форму его, а также 2 текстовых поля и 1
командную кнопку. Первое текстовое поле будет служить для ввода URL
страницы, которую Вы желаете скачать (например,
"http://www.chto_to.ru/Index.html"), а второе - полный путь и имя файла для
ее сохранения на Вашем компьютере (например, "C:\Temp\Index.html").

ОТКУДА БРОУЗЕР БЕРЕТ НОВЫЙ АДРЕС?

Вопрос не относится к Visual Basic!!! Отвечу кратко. В броузере постоянно
отображается тот адрес на который переходит ссылка. Поэтому, даже если Вы
зашли на введенную Вами страницу, то скрипты этой страницы могут перебросить
Вас на нужную для них страницу, которая и отобразится в броузере. Используя
приведенный выше пример, этого не произойдет - скачается введенная Вами
страница.

Приложение к ответу (исходный код):
Вставьте в модуль формы следущий код: Option Explicit Dim vData As Variant Private Sub Command1_Click() If Len(Text1) = 0 Or Len(Text2) = 0 Then Exit Sub Rem: Text1.Text - это адрес URL, _ который Вы введете в текстовое поле объекта Text1 _ поэтому если поле пустое, то нет смысла делать ошибку Inet1 Rem: Text2.Text - это полный путь и имя файла _ где Вы хотите сохранить скачаную страницу, _ который Вы перед скачиванием введете в текстовое поле объекта Text2 _ поэтому чтобы программа не закрылась, _ написав Path Not Found, прервем процесс, если Text2.Text пустой vData = Inet1.OpenURL(Text1.Text, icString) End Sub Private Sub Inet1_StateChanged(ByVal State As Integer) If State = 12 Then Rem: Файл получен. Теперь сохраняем его на своем компьютере: Open Text2.Text For Output As #1 Print #1, , vData Close #1 MsgBox "Файл успешно сохранен в папке:" _ & vbNewLine & Text2.Text, 64 + 0, App.Title End If End Sub

---

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


Отвечает: Alen Pelin
PHP - это не страница. PHP - это скрипт, который выводит на экран
страницу. Возможно данный скрипт просто перенаправляет вас на другую
страницу.

---

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

---

134/Здравствуйте!
У меня вот какая проблемка возникла,Была создана база данных,после чего на Visual Basic были созданы формы,в одной из них через DataGrid возможно просмотреть базу как обычно.Так же через DataGrid можно добавить в базу новые данные.
Но вроде бы все хорошо,и все получается, вот только есть одно Но.
А именно через другую форму в которой находятся текстовые поля и один ComboBox(для выбора данных из списка) нужно данные которые пользователь введет в тестовые поля добавить в базу данных.
Что я только не делал,не чего не получается:(
Please погите начинающему,вроде делал все как в книге написано,а выдает ошибку хоть убейся(Ошибка синтаксиса в инструкци INSERT INTO)
Так же предоставляю листинг где происходит ошибка.

В форуме посоветовали в место точек проставить запятые,поставил ошибка исчезна,но появилась новая говорит что не может найти колонку "N Порядковый номер" убрал эту колонку и все что сней было связано,появилась ошибка,что не может найти колонку " Полки"
Пожалуйста помогите разобратс


Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
'После проверки заполнения текстовых полей, после нажатия кнопки "OK" данные добовляются в базу данных через DataGrid
If (Trim(TextBox1.Text) = " ") Then
MsgBox("Не Задан Порядковый Номер") : Exit Sub
End If
If (Trim(TextBox2.Text) = " ") Then
MsgBox("Не задан Жанр Книги") : Exit Sub
End If
If (Trim(TextBox3.Text) = " ") Then
MsgBox("Не задано Название книги") : Exit Sub
End If
If (Trim(ComboBox1.Text) = " ") Then
MsgBox("Не задан Автор Книги") : Exit Sub
End If
If (Trim(TextBox5.Text) = " ") Then
MsgBox("Не задано Название Рассказа") : Exit Sub
End If
If (Trim(TextBox7.Text) = " ") Then
MsgBox("Не задано Полки Книги") : Exit Sub
End If
If (Trim(TextBox9.Text) = " ") Then
MsgBox("Не задан Год Выпуска Книги") : Exit Sub
End If
If (Trim(TextBox10.Text) = " ") Then
MsgBox("Не задано Содержание Книги") : Exit Sub
End If
Dim sSQL As String
sSQL = "INSERT INTO Spravochnik" & "([N Порядковый Номер]. [ Полки]. [ Книги]. Жанр. [Название Книги]. [Год Выпуска]. Содержание. [Название Рассказа]. Примечание1. Комментарий. Примечание2, Код)" & _ "VALUES (" & TextBox1.Text & ",'" & TextBox7.Text & "'," & TextBox8.Text & ",'" & _ TextBox2.Text & "','" & TextBox3.Text & "'," & TextBox9.Text & ",'" & _ TextBox10.Text & "','" & TextBox5.Text & "','" & TextBox11.Text & "','" & _ TextBox6.Text & "','" & TextBox12.Text & "','" & ComboBox1.Text & "') "
Try
ExecSQL(sSQL)
Me.DialogResult = DialogResult.OK
Close()
Catch myExeption As Exception
MsgBox(myExeption.Message)
End Try
End Sub

Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
'Процедура кнопки Отмена
Me.DialogResult = DialogResult.Cancel
Close()
End Sub

Private Sub Label1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Label1.Click

End Sub

Private Sub TextBox2_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TextBox2.TextChanged

End Sub

Private Sub Dobavity_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

End Sub
End Class


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

Отвечает: Игорь Осипов
Доброе время суток! Сам поначалу матерился в подобных ситуациях.
Моя ошибка была именно в инструкции SQL (как, по-моему и у Вас) -
обратите внимание на соединение строк. Например,
... "INSERT INTO Spravochnik" & "([N Порядковый Номер] ... Примечание2, Код)" & _ "VALUES ...
после объединения Вы получите следующее:
INSERT INTO Spravochnik([N Порядковый Номер] ... Примечание2, Код)VALUES (
(БЕЗ ПРОБЕЛА между служебными словами SQL).
Т.е. необходимо по краям слов добавить пробелы.
Кстати, я в таких случаях использую Debug.print sSQL, что бы
проверить, что там я наприсоединял.

---

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

---

135/Здравствуйте! Как сделать так чтобы неактивное окно отображалось на экране, не перекрывалось другими окнами, а фокус ввода оставался у активного окна? [Ответить]

Отвечает: Игорь
Доброе время суток! Сам поначалу матерился в подобных ситуациях.
Моя ошибка была именно в инструкции SQL (как, по-моему и у Вас) -
обратите внимание на соединение строк. Например,
... "INSERT INTO Spravochnik" & "([N Порядковый Номер] ... Примечание2, Код)" & _ "VALUES ...
после объединения Вы получите следующее:
INSERT INTO Spravochnik([N Порядковый Номер] ... Примечание2, Код)VALUES (
(БЕЗ ПРОБЕЛА между служебными словами SQL).
Т.е. необходимо по краям слов добавить пробелы.
Кстати, я в таких случаях использую Debug.print sSQL, что бы
проверить, что там я наприсоединял.

Приложение к ответу (исходный код):
Option Explicit Private Declare Function SetWindowPos _ Lib "user32" (ByVal h%, _ ByVal hb%, _ ByVal x%, _ ByVal Y%, _ ByVal cx%, _ ByVal cy%, _ ByVal F%) As Integer Const SWP_NOMOVE = 2 Const SWP_NOSIZE = 1 Const flags = SWP_NOMOVE Or SWP_NOSIZE Const HWND_TOPMOST = -1 Const HWND_NOTOPMOST = -2 Dim res As Integer Private Sub Check1_Click() With Check1 Select Case .Value Case vbChecked .Caption = "Форма поверх всех" res = SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, flags) 'Форма on-top Case vbUnchecked .Caption = "Форма НЕ поверх всех" res = SetWindowPos(Me.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, flags) 'Форма non-on-top End Select End With End Sub Private Sub Form_Load() Check1.Caption = "Форма НЕ поверх всех" Check1.Width = 2500 End Sub Тестировать программу желательно (но и не обязательно) после компиляции. При нажатии на CheckBox окно Вашей программы будет отображаться поверх всех открытых в это время окон, и фокус ввода, конечно же, останется у активного окна, хоть оно и будет перекрыто неактивным окном Вашей программы пока вы не снимите отметку с CheckBox "Отображать поверх всех". *** Все бы было хорошо, если бы Вы правильно задали свой вопрос. Из Вашего вопроса не ясно, какое окно Вы хотите отображать поверх всех. Возможно, это совершенно не окно Вашей программы, а другое окно посторонней программы запущенно в данный момент. Тогда для этого существует другой подход. Перед тем, как отобразить желаемое Вами окно не перекрываемым необходимо вычислить его Handl. Для этого существует много способов. Ниже приведен пример с использованием заголовка окна. Ничего не меняйте из предыдущего примера, кроме кода, который замените на следующий: Option Explicit Private Declare Function FindWindow _ Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos _ Lib "user32" (ByVal h%, _ ByVal hb%, _ ByVal x%, _ ByVal Y%, _ ByVal cx%, _ ByVal cy%, _ ByVal F%) As Integer Const SWP_NOMOVE = 2 Const SWP_NOSIZE = 1 Const flags = SWP_NOMOVE Or SWP_NOSIZE Const HWND_TOPMOST = -1 Const HWND_NOTOPMOST = -2 Dim res As Integer Private Function hand() As Long hand = FindWindow(vbNullString, "Калькулятор") 'hand - содержит Handle (или дескриптор) окна с заголовком Калькулятор End Function Private Sub Check1_Click() With Check1 Select Case .Value Case vbChecked .Caption = "Калькулятор поверх всех" res = SetWindowPos(hand, HWND_TOPMOST, 0, 0, 0, 0, flags) 'Форма on-top Case vbUnchecked .Caption = "Калькулятор НЕ поверх всех" res = SetWindowPos(hand, HWND_NOTOPMOST, 0, 0, 0, 0, flags) 'Форма non-on-top End Select End With End Sub Private Sub Form_Load() Check1.Caption = "Калькулятор НЕ поверх всех" Check1.Width = 2500 End Sub Этот пример демонстрирует отображение поверх всех окна программы (в нашем случае программы "Калькулятор"), но не той, из которой эта функция вызывается.

---

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


Отвечает: EnzO)Stalker
Постараюсь ответить. Нужно неактивное окно сделать поверх всех окон. Вот как это делается:

Приложение к ответу (исходный код):
Public 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 Public Const HWND_NOTOPMOST = -2 Public Const HWND_TOPMOST = -1 Public Const SWP_NOACTIVATE = &H10 Public Const SWP_NOMOVE = &H2 Public Const SWP_NOSIZE = &H1 Public Sub SetFormPosition(frmHandl As Long, TopPosition As Boolean) If TopPosition Then SetWindowPos frmHandl, HWND_TOPMOST, 0, 0, 0, 0, _ SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE Else SetWindowPos frmHandl, HWND_NOTOPMOST, 0, 0, 0, 0, _ SWP_NOSIZE Or SWP_NOMOVE End If End Sub ---------------------------------------- В процедуре Load формы пишешь: Private Sub Form_Load() call SetFormPosition(Me.hwnd, True) End Sub А лучше этот код поместить в процедуре Timer элемента управления Timer: Private Sub Timer1_Timer() call SetFormPosition(Me.hwnd, True) End Sub Высылаю исходник где все это есть.

---

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

---

137/Привет! Подскажите как показать анимацию GIF'а [Ответить]

Отвечает: Игорь
Когда-то в Нете я нашел ответ на Ваш вопрос, но так его и не скачал, так как
размер кода программы для этой функции был приблизительно на 3-4 страницы
формата А4. Я подумал, что такой подход к мало кого устраивает: Сейчас Вам
могу предложить лишь следующий способ, который, возможно, Вас тоже мало
устроит, но все же:

Способ воспроизведения файлов формата GIF анимации при помощи элемента
WebBrowser. Этот стандартный инструмент для проектирования броузера отлично
работает в качестве проигрывателя! Для установки этого компонента подключите
Microsoft Internet Controls к вашему проекту, после чего разместите его на
форме так, что бы размеры не были слишком маленькими - это будущий экран.
Код такой:

Приложение к ответу (исходный код):
Private Sub Form_Load() Dim Mult As String Dim pat As String pat = App.Path & "\Example.gif" ' имя вашего файла Mult = "about:<html><body bgcolor=#0033CC scroll='no'>" & _ "<img border='0' dynsrc = " & _ " '" & pat & "'" & " start='fileopen' </body></html>" WebBrowser1.Navigate Mult WebBrowser1.Visible = True End Sub Бред, конечно же, если найду что-то лучше обязательно напишу:

---

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


Отвечает: Sergey Strizhakov
привет! Лично я пользуюсь осиксом AniGif (DSMAniGifControl.ocx ) просто и удобно, хотя можно
писать свою функцию

---

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

---

138/Привет! Подскажите как воспоизвести SWF? [Ответить]

Отвечает: Игорь
Для отображения Flash (.swf) анимации в VB используется ActivX элемент
Shockwave Flash (FLASH.OCX). Подключите его к вашему проекту
(Меню/Компоненты). Правда, не знаю, поставляется ли он вместе с пакетом
Visual Basic, скорее всего, нет, но Вы можете найти FLASH.OCX через поиск.
Он не находится в папке SYSTEM, но обычно у всех на компе есть. Разместите
вышеназванный компонент на форме и разместите следующий код:

Приложение к ответу (исходный код):
Private Sub Form_Load() ShockwaveFlash1.Movie = App.Path & "\example.swf" ' Имя вашего файла ShockwaveFlash1.Menu = True ShockwaveFlash1.Play Me.Caption = ShockwaveFlash1.Movie End Sub Private Sub Form_Resize() ShockwaveFlash1.Move 0, 0, Me.Width, Me.Height End Sub Всего-то! Вообще у ShockwaveFlash много функций, посмотрите сами, можно поэкспериментировать, лишь бы FLASH.OCX был у Вас.
Скачать прикрепленный файл >>>

---

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


Отвечает: Sergei
При помощи компонента ShockwaveFlash. В свойстве Movie путь к файлу
swf (, например, file:///patch_for_you_flash.swf).

---

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

---

139/Здраствуйте. Подскажите, плз, как в PictureBox'e растянуть изображение? Просьба ответы типа "поставь Image. Свойство Stretch = True" не присылать. Заранее благодарен. [Ответить]

Отвечает: EnzO)Stalker
Меня тоже интересовал этот вопрос, и вот я нашел на него ответ.

Создаешь на форме два PictureBox'a с именами picHidden и picVisible. На picHidden вешаешь картинку которую нужно растягивать и ставишь свойство Visible равным False, а picVisible оставляешь пустым. Далее пишешь код:

Приложение к ответу (исходный код):
' Растягиваем picVisible по форме Private Sub Form_Resize() picVisible.Move 0, 0, ScaleWidth, ScaleHeight End Sub ' Копируем картинку из picHidden в picVisible Private Sub picVisible_Resize() picVisible.PaintPicture picHidden.Picture, _ 0, 0, picVisible.ScaleWidth, _ picVisible.ScaleHeight, _ 0, 0, picHidden.ScaleWidth, _ picHidden.ScaleHeight, vbSrcCopy End Sub

---

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


Отвечает: Игорь
Ответ, типа, поставь свойство "STRETCH = TRUE" Вам никто и не прислал бы,
даже если бы Вы НЕ написали этого, т.к. в элементе PictureBox этого свойства
просто-напросто НЕТ!

Два способа растянуть изображение, в зависимости от того, куда Вы хотите его
растягивать. Вы не указали тип "растягивания".

1) Если Вы хотите растянуть изображение так, чтобы оно полностью поместилось
в Ваш PictureBox в реальном своем размере (если, конечно же, размеры формы
позволят).

Разумеется, сначала поместить объект PictureBox на форму, затем вставить
код:

Приложение к ответу (исходный код):
Private Sub Form_Load() Picture1.AutoSize = True Picture1.Picture = LoadPicture([FileName], [Size], [ColorDepth], [X], [Y]) End Sub где: FileName - полный путь и имя файла рисунка, который Вы хотите отобразить. Для выбора можно использовать CommonDialog; Size - размер Picture (vbLPCustom, vbLPLarge, vbLPLargeShell, vbLPSmall или vbLPSmallShell); ColorDepth - цветовая гамма; X и Y - положение по горизонтали и вертикали на форме соответствено. Все параметры функции LoadPicture необязательные (Optional), т.к. стоят в скобочках, т.е. их можно и не указывать: 2) Если Вы хотите загрузить картинку и установить свои размеры: Private Sub Form_Load() Picture1.AutoSize = False Picture1.Height = 5000 'или какой захотите Picture1.Width = 1200 'или какой захотите Picture1.Picture = LoadPicture([FileName], [Size], [ColorDepth], [X], [Y]) End Sub Описание функции LoadPicture см. выше. Свойство Picture1.AutoSize указывает на необходимость обрезать картинку (False) либо растянуть ее по всему выбраному Вами пространству (True).

---

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


Отвечает: Копылов Сергей
Никак. 100%

---

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

---

140/Здравствуйте!
Я с VB знаком давно но руки не доходили до него написать что-то
серйозное. Решил написать программу для создания комбинаций клавиш на
мыши. Например: Колесо + Левая кнопка мыши = Копировать, и т. п. Но я
никак не могу определить какая же кнопка мыши нажата(или колесо).
Заранее благодарен. [Ответить]

Отвечает: EnzO)Stalker
Попробуй этот код, может поможет:

Приложение к ответу (исходный код):
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Then MsgBox "Левая кнопка мыши" ElseIf Button = vbRightButton Then MsgBox "Правая кнопка мыши" ElseIf Button = vbMiddleButton Then MsgBox "Колесо прокрутки (Средняя кнопка мыши)" End If End Sub Но я все же не нашел способа отловить нажатия одновременно двух клавишь:(

---

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


Отвечает: kel'
Проще всего (и эффективнее) это сделать через WinApi. В отдельном
модуле создаете вызов функции GetKeyState:
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

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

Приложение к ответу (исходный код):
Private Sub Command1_Click() Dim MouseKeyState As Long ' состояние кнопки ' Читаем текущее состояние левой кнопки. MouseKeyState = GetKeyState(&H1) '&H1 - код левой кнопки мыши If (MouseKeyState And &H80) = &H80 Then ' а здесь &H80 - возвращаемое фукцией значение, если оно равно &H80, то кнопка нажата, если нет, то кнопка отжата. Label1.Caption = "Левая кнопка мыши в настоящее время нажата." Else Label1.Caption = "Левая кнопка мыши сейчас не нажата." End If End Sub Значения A-Z и 0-9 соответсвуют их ASCII кодам. А вот список остальных (да простит меня ведущий рассылки): &H1 - Левая кнопка мыши &H2 - Правая кнопка мыши &H3 - Комбинации клавиш Control-Break &H4 - Средняя кнопка мыши &H8 - Backspace &H9 - Tab &HC - 5 (на цифровой клавиатуре без Num Lock) &HD - Enter &H10 - Shift (любая) &H11 - Ctrl (любая) &H12 - Alt (любая) &H13 - Pause &H14 - Caps Lock &H1B - Esc &H20 - Пробел &H21 - Page Up &H22 - Page Down &H23 - End &H24 - Home &H25 - Стрелка влево &H26 - Стрелка вверх &H27 - Стрелка вправо &H28 - Стрелка вниз &H29 - Select &H2C - Print Screen &H2D - Insert &H2E - Delete &H5B - Кнопка Win (открывает меню "Пуск") &H5D - Контекстное меню (заменяет правую кнопку мыши, обычно рядом с Win) &H6A - * (цифровая клавиатура) &H6B - + (цифровая клавиатура) &H6E - . (с Num Lock) &H6F - / (цифровая клавиатура) &H70 - F1 &H71 - F2 &H72 - F3 &H73 - F4 &H74 - F5 &H75 - F6 &H76 - F7 &H77 - F8 &H78 - F9 &H79 - F10 &H7A - F11 &H7B - F12 &H90 - Num Lock &H91 - Scroll Lock &HBA - ; &HBB - = &HBC - , &HBD - - &HBE - . &HBF - / &HC0 - ` &HDB - [ &HDC - \ &HDD - ] &HDE - '

---

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

---

141/Привет! как вернуть управление сразу же после вызова функции( т.е. чтобы вызванная функция выполнялась, и продолжала выполнятся процедура вызвавшая эту функцию одновременно) [Ответить]

Отвечает: Игорь
Обычно всегда так и происходит. Скорее всего Вы нарвались на функцию,
которая выполняется синхронно. т.е. управление командам, следующим за этой
функцией будет передано только тогда, когда функция будет выполнена. Иными
словами Ваша программа становится "замороженой". Если я Вас правильно понял,
то решить Вашу проблему смогу только зная, что за функцию Вы имеете в виду.
В большинстве случаев синхронные команды можно замениь на асинхронные, либо
же выкрутится всегда можно. Но нет смысла объяснять как это делается, не
зная что за функцию Вы имеете в виду. Увы, но все советы Вам по этому поводу
МОГУТ оказаться безнадежными (но, возможно, Вам и повезет).

---

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

---

142/ Здравствуйте уважаемые программисты!
Как создать файл имя которого переменная adres?
Заранее спасибо! [Ответить]

Отвечает: Sergey Strizhakov
Привет! Open adres & ".txt" for [mode] as #1
ИМХО так!

---

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

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

Трюки с CD-Rom
CD-ROM. Открываем и закрываем	Скачать
Модуль: Управление CD-Rom	Скачать
Формы: операции с формами
Вызывает стандартное окно About	Скачать
Запрещаем нажатие кнопки X на форме	Скачать
Модуль: Прозрачные окна	Скачать
Модуль: Разные формы	Скачать
Перетаскивание окна не за заголовок	Скачать
Операции с формами (отображение, скрытие, загрузка, выгрузка) New!!!	Скачать
Форма с закругленными концами	Скачать
VBA – все, относящееся к прикладному программированию
Excel - программное создание базы данных в книге Excel New!!!	Скачать
Проверка орфографии с помощью Word	Скачать
Файлы – операции с файлами
Модуль: Считывает размер файла, папки	Скачать
Применение FSO в приложении	Скачать
Пример показывает анимирование Gif-файла в приложении	Скачать
Просмоторщик ресурсов	Скачать
Создание MP3-коллекции файлов New!!!	Скачать
Файлы - стандартные операции с файлами в VB New!!!	Скачать
Операции с BMP (создание волн)	Скачать
Создание щтрих-кода в BMP-файле	Скачать
Реестр и INI-файлы
INI-файлы. Очень подробный пример для работы с Ini-файлами в приложении New!!!	Скачать
Изменяем параметры Internet Explorer New!!!	Скачать
Модуль: Работа с реестром	Скачать
Работа с реестром	Скачать
Пример реализации проверки файлов методом CRC New!!!	Скачать
Панель задач и трей
Progress Bar в Task Manager	Скачать
Блокирование/разблокирование, скрытие/отображение кнопки ПУСК New!!!	Скачать
Иконка в трее	Скачать
Иконка в трее	Скачать
Модуль: Иконка в трее	Скачать
Модуль: Иконка в трее 2	Скачать
Программно впихиваем текст в панель задач (рядом с часами) New!!!	Скачать
Часики в трее	Скачать
Меню в Visual Basic
Меню с использованием BMP-файлов (1)	Скачать
Меню с использованием BMP-файлов (2)	Скачать
Стильное VB меню	Скачать
Диалоги в Visual Basic
Вызов стандартного диалога открытия файла без использования контрола	Скачать
Модуль: Стандартные диалоги	Скачать
Элементы управления в Visual Basic
Кнопка XP New!!!	Скачать
Крутой ProgressBar	Скачать
Магическая кнопка! New!!!	Скачать
Перебор цвета в Combo Box New!!!	Скачать
Поворот текста под любым углом в PictureBox New!!!	Скачать
Работа с таблицами в MSFexGrid New!!!	Скачать
Создание таблицы с заголовками из ListBox	Скачать
Текст под любым углом в PictureBox New!!!	Скачать
Windows XP Style все по работе со стилями
Модуль: XP стиль	Скачать
ХР стиль в приложении Visual Basic	Скачать
Разное
Запрет нажатия клавиш Ctrl+Alt+Del	Скачать
Звонилка New!!!	Скачать
Информация о текущем пользователе New!!!	Скачать
Модуль: Информация о жестком диске	Скачать
Модуль: Программное переключение языка ввода с клавиатуры	Скачать
Модуль: Сортировка массива	Скачать
Модуль: Функции выключения, перезагрузки компьютера	Скачать
Модуль: Шатдаун компьютера	Скачать
Монитор статуса соединения с сетью New!!!	Скачать
Пример известной игры Lines	Скачать
Работа с DirectX	Скачать
Работа с консолью в windows	Скачать
Работа с портами в Windows	Скачать
Создание анимированных изображений	Скачать
Создание программы установки	Скачать
Считывает серийный номер жесткого диска	Скачать
Удаленное подключение к компьютеру	Скачать
Устанавливаем приоритет приложения в Windows	Скачать
Цифровое табло	Скачать
Часики	Скачать
Часы с таймером	Скачать
Читаем разную информацию о БИОСЕ	Скачать

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

Леха хочет задать два вопроса по статье: Как заставить работать Package & Deployment Wizard в Visual Basic 6.0

У меня 2 вопроса по поводу статьи "Как заставить работать Package & Deployment Wizard в Visual Basic 6.0" (кстати особое спасибо Игорю за статью, она очень помогла):
1. Есть ли программа которая создаёт не инсталляционных пакетов, а для деинсталляционных?
2. Можно ли сделать в Package & Deployment Wizard, чтобы Setup устанавливал не одно приложение, а допустим два соеденённым в vbg файл, к примеру если я создаю игру менеджер футбольного клуба, первый проект сама игра, а второй редактор базы данных?
Заранее спасибо.

Ответы направлять СЮДА

Опять же Игорь прислал в нашу рассылку статью. Спасибо Игорь за статью. По новым правилам Вы получаете дополнительно 10 баллов!

INTERNET TRANSFER CONTROL

Раньше работа с Internet, для программистов на Visual Basic, была возможна только используя непосредственный вызов функций API. С выпуском Visual Basic 5 все изменилось в связи с включением специального ActiveX компонента Internet Transfer Control. Internet Transfer Control обеспечивает поддержку двух стандартных протоколов FTP и HTTP. Протокол HTTP позволяет Вам соединяться с серверами world wide web и получать доступ к файлам. FTP протокол позволяет получать любой вид файлов от сервера FTP Internet, а также посылать их на такие же серверы, однако, в отличие от HTTP протокола, имеет больше возможностей.
Internet Transfer Control - фактически является интерфейсом к основной Internet библиотеке Windows WININET.DLL. Эта DLL - часть Win32 API. И Internet Explorer работает, вызывая функции из этой самой библиотеки. А зачем нам тогда этот Internet Transfer Control? Да, в принципе и не нужен, если только Вы не боитесь заблудиться в темном лесу под названием WININET.DLL.

ПОЛУЧЕНИЕ ФАЙЛОВ ИЗ INTERNET ПО HTTP ПРОТОКОЛУ
Рассмотрим получение файлов из Internet по протоколу HTTP. Существует два метода используемых для получения файлов: OpenURL и Execute.

Синхронный метод
Метод OpenURL используется, чтобы получить доступ к документу в Internet и помещает его копию на локальном компьютере. URL, который передается как параметр для метода OpenURL, может быть любым документом. Все, что Вы должны определить - URL документа, который Вам требуется и тип документа icString (текстовый файл) или icByteArray (бинарный файл, для программ и архивов). Вначале посмотрим, как получить обычный текстовый файл:
Dim vData As Variant
vData = Me.Inet1.OpenURL("http://www.vbnet.ru/default.asp", icString)

Итак, файл получен. Что мы можем с ним сделать? Например, сохранить на своем компьютере:
Open "C:\index.htm" For Output As #1
Print #1, , vData
Close #1

Файл получен и сохранен, теперь его можно посмотреть в любой программе, или написать свою для его просмотра.

Внимание: Метод OpenURL выполняется синхронно, т.е. управление в Вашу программу будет передано только тогда, когда передача запрашиваемого файла будет завершена. Иными словами, Ваша программа будет неспособна выполняться пока идет передача файла и, если файл большой, а связь медленная, то Вы можете испытывать некоторые трудности с использованием этого метода, дело в том, что Ваша программа окажется «замороженной» на пару часиков в случае если принимаемый файл имеет внушительные размеры, ну и кому это понравится? Зато легко, но не очень хорошо, но легко.
После, того, как Вы открыли файл методом OpenURL, Вам становятся доступны некоторые его свойства, которые тоже могут быть Вам полезны.

Значение
Описание
Date
Возвращает время и дату передачи документа.
Формат: Wednesday, 24-April-05 19:34:15 GMT
MIME-version
Возвращает версию протокола MIME.
Server
Возвращает название сервера.
Content-length
Возвращает размер документа в байтах.
Content-type
Возвращает MIME тип данных.
Last-modified
Возвращает дату и время последней модификации документа.
Формат: Wednesday, 24-April-05 19:34:15 GMT

Итак, допустим, что Вы хотите узнать размер открытого документа. Для этого используйте такой код:
Dim sLenth As String
sLenth = Inet1.GetHeader("Content-length")

Внимание: Метод GetHeader можно использовать только после принятия заголовка или открытия документа методом OpenURL. Если Вы захотите узнать, например размер еще не открытого документа, то произойдет ошибка. Поэтому перед приемом документа, я рекомендую узнать его заголовок. Это позволит Вам определить размер документа и контролировать прогресс его приема.

Если Вам нужно принять только заголовок документа, то воспользуйтесь следующим кодом:
Inet1.Execute , "HEAD"
'задержка, пока запрос не выполнен
Do
If Not Inet1.StillExecuting Then Exit Do
DoEvents
Loop
Dim lLenthFile As Long
lLenthFile = CLng(Inet1.GetHeader("Content-length"))
s = "Date: " & Inet1.GetHeader("Date") & vbCrLf
s = s & "MIME-version: " & Inet1.GetHeader("MIME-version") & vbCrLf
s = s & "Server: " & Inet1.GetHeader("Server") & vbCrLf
s = s & "Content-length: " & CStr(lLenthFile) & vbCrLf
s = s & "Content-type: " & Inet1.GetHeader("Content-type") & vbCrLf
s = s & "Last-modified: " & Inet1.GetHeader("Last-modified") & vbCrLf
Label1.Caption = s

Обратите внимание на переменную lLenthFile, которая равна размеру принимаемого файла. Это нам может потребоваться в дальнейшем.

Внимание: Если принимаемый документ не бинарный файл или не HTML документ, а является ASP или другим динамически формируемым документом, то принятый заголовок может содержать искаженную информацию, например о его размере. Это связано с тем, что получить размер еще не существующего документа невозможно.

Асинхронный метод
Для того, чтобы выполнение программы не прерывалось, существует способ асинхронной передачи файлов. Давайте рассмотрим его подробнее. Для асинхронной работы существует метод Execute.
Execute метод посылает команду на отдаленный сервер Internet. Команда может быть запросом для получения, передачи файла на сервер, удаления, переименования файла и т.д. Кроме того, серверы HTTP имеют набор команд, которые позволяют Вам не, только получать или передавать файлы, но также могут передавать различную информацию о документе, сохраненном на сервере. Как только сервер получил команду, которая была передана ему Execute методом, он посылает ответ на Вашу программу, вызывая StateChanged событие Internet Transfer Control. Событие StateChanged имеет параметр, который указывает действие, которое удаленный компьютер только что выполнил. Как только это событие было вызвано, Вы можете предпринять какие либо действия в Вашей программе. В настоящее время документированы следующий команды для HTTP серверов: GET - прием файла с сервера, HEAD - прием заголовка, POST - альтернативный метод приема данных и PUT - передача данных на сервер.
Итак, допустим, что Вы запросили на сервере файл mydocument.zip. Сервер принял Вашу команду и начинает возвращать Вам данные. Для получения данных, которые были переданы на Ваш компьютер, Вам нужно обратиться к методу GetChunk. Но здесь не все так просто, дело в том, что данные передаются не все сразу, а по частям или порциями. Обычно (по умолчанию) размер каждой порции данных 1024 байт. Это означает, что, если Вы требовали файл, который имеет размер 100 Кб, то Вы должны вызвать GetChunk метод примерно 100 раз, чтобы получить все требуемые данные. Для чего это сделано? Представте себе, что Ваша программа принимает файл размером 1 Мб, а скорость Вашего соединения с Internet 19200 бод. Это означает, что Ваша программа будет принимать файл примерно в течении 10 минут. Как Вы думаете, стоит сообщать пользователю Вашей программы о том, какая часть файла уже принята и сколько осталось еще принять? Думаю, что стоит.
Да, кстати, если Вы думаете, что сервер всегда должен Вам возвратить данные, то Вы глубоко заблуждаетесь. Если Вы захотите удалить файл на сервере и пошлете ему правильную команду, то сервер сразу же скажет OK и удалит этот файл. А вот данных Вы от него никаких тогда не получите, но событие StateChanged произойдет и параметр State примет значение icResponseCompleted (т.е. State = 12). Значит все в норме, и запрос был успешно выполнен.
Теперь давайте посмотрим на код. Обратите внимание, что прием данных ведется в переменую vtData(), имеющую тип Byte. Это сделано для того, чтобы можно было принимать любые типы файлов: текстовые и бинарные. С той же целью метод GetChunk вызывается с параметром icByteArray:
Private Sub Inet1_StateChanged(ByVal State As Integer)
Dim vtData() As Byte
Dim intFile As Long
Select Case State
'здесь можно обрабатывать другие события
Case icResponseCompleted '12
'открываем файл для записи принимаемых данных
intFile = FreeFile
Open Me.txtFileName For Binary Access Write As #intFile
'принимаем первую порцию данных
vtData = Inet1.GetChunk(1024, icByteArray)
Do While LenB(CStr(vtData)) > 0
Put #intFile, , vtData
'следующая порция данных
vtData = Inet1.GetChunk(1024, icByteArray)
UpdateStatus Seek(1)
Loop
Put #intFile, , vtData
Close #intFile
End Select
Me.stb.SimpleText = GetConnectionState(State)
End Sub

Еще необходимо обратить внимание на код процедуры UpdateStatus. Она отвечает за вывод информации о прогрессе приема файла. Для этого используется глобальная переменная lLenthFile, содержащая размер документа на сервере и передаваемый размер уже принятых данных. Процедура очень простая и служит только для того, чтобы записать в строку состояния, сколько принято данных в процентах от их общего количества.
Sub UpdateStatus(lRec As Long)
Dim i As Long
i = lRec * 100 / lLenthFile
stb.SimpleText = "Принято: " & i & "%"
Rem: stb - это StatusBar (Microsoft Common Controls 6.0) со свойством style="Simple"
DoEvents
End Sub

И ничего нет здесь сложного. Так, теперь мы знаем для чего нужно событие StateChanged и давайте посмотрим, какую информацию мы можем еще получать, используя его.

Константа
Значение
Описание
icNone
0
Информация о состоянии не доступна
icResolvingHost
1
Поиск IP адреса сервера
icHostResolved
2
IP адрес сервера найден
icConnecting
3
Соединение с сервером
icConnected
4
Соединился с сервером
icRequesting
5
Запрос информации с сервера
icRequestSent
6
Запрос на сервер успешно отправлен
icReceivingResponse
7
Получение ответа от сервера
icResponseReceived
8
Ответ от сервера был успешно принят
icDisconnecting
9
Отключение от сервера
icDisconnected
10
Отключение от сервера выполнено
icError
11
Произошла ошибка во время сеанса связи с сервером
icResponseCompleted
12
Запрос выполнен, все данные получены

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

Для этого можно написать специальную функцию, которая бы возвращала по коду (от 0 до 12) его описание. Кроме того, можно сделать поддержку двух или более языков, на которых будут выводиться сообщения. Что же касается кода этой функции, то он достаточно простой:

Function GetConnectionState(intState As Integer) As String
Dim s As String
Select Case intState
Case Is = 0: s = "Информация о состоянии не доступна."
Case Is = 1: s = "Поиск IP адреса сервера..."
Case Is = 2: s = "IP адрес сервера найден..."
Case Is = 3: s = "Соединение с сервером..."
Case Is = 4: s = "Соединился с сервером..."
Case Is = 5: s = "Запрос информации с сервера..."
Case Is = 6: s = "Запрос на сервер успешно отправлен..."
Case Is = 7: s = "Получение ответа с сервера..."
Case Is = 8: s = "Ответ с сервера был успешно получен..."
Case Is = 9: s = "Отключение от сервера..."
Case Is = 10: s = "Отключение от сервера выполнено."
Case Is = 11: s = "Произошла ошибка во время сеанса связи."
Case Is = 12: s = "Запрос выполнен, все данные получены."
End Select
GetConnectionState = s
End Function

Заключение
В этой статье рассказано, как можно использовать Internet Transfer Control для передачи файлов в сети Интернет. Однако, в ней описано только использование HTTP протокола, который, в отличие от другого FTP протокола обладает большей гибкостью в использовании.

P.S.: Пример к статье - см. Ответ на Вопрос № 128.

 

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

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

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