конечно можно, два отдельных потока, в каждом свой цикл
------------------
Best regards, _bob

а я не советую ругать то, чего не знаете

я утверждаю: написать нормальное, устойчиво работающее многопоточное приложение на VB6 МОЖНО, т.к. я такое делал и оно прекрасно работает (причем в о-о-очень серьёзной компании), см. соседний топик про copymemory, я там как раз вчера про многопоточный бейсиковый NTService писал

------------------
Best regards, _bob

Alexey Kudinov в VB6 нельзя написать нормальное многопотоковое приложение

я понимаю слово нельзя так: попытка сделать то, что нельзя, в подавляющем большинстве случаев приводит к неудаче (нельзя съесть мешок брюквы одному человеку за два часа)

Alexey Kudinov Это означает лишь, что лично вы сделали некую вещь, которая где-то хорошо работает. Ну и ?

это означает именно то, что факт стабильной работы многопоточного приложения на VB опровергает ваше ошибочное утверждение, будто этого сделать нельзя (если кому-то удастся проделать трюк с мешком брюквы, это будет означать, что я неправ, невзирая ни на мое личное мнение, ни на статистические данные всех вместе взятых докторов и диетологов)

вот "облегченная версия" двухпоточного сервиса, main работает в одном потоке (как раз цикл крутит и в процедуре timer выполняет функционал), во втором потоке работает обработчик сервисных сообщений windows и остальной сервисный функционал, оба потока работают независимо друг от друга, в обоих потоках ведется работа с БД, тормоза в одном потоке не влияют на другой, незадекларенные api-фукции необходимо описать в библиотеке типов или скачать из инета библиотеку типов VB-friendly NT Service API Functions (NTVBSvc.tlb) и подключить её к проекту, если в приведённых исходниках убрать закомментарить фукции и процедуры, относящиеся к функционалу (я их не выкладывал), то проект нормально откомпилируется и будет работать (делать, ессно, ничего не будет, только стартовать как сервис и останавливаться)

по аналогии можно сделать простое двухпоточное приложение (не сервис), оно так же будет нормально работать

много лишних декларов, просто некогда разбираться, что пригодится, что нет, высылаю так

Private 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
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private 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
Private Const WS_POPUP = &H80000000
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Const WM_DESTROY = &H2
Private Const WM_MS = &H1C


Private Declare Function CreatePopupMenu Lib "user32" () As Long
'Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private 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, lprc As RECT) 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
Private 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
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long


Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_COMMAND = &H111
Private Const WM_NULL = &H0

Private Const TPM_CENTERALIGN = &H4
Private Const TPM_LEFTALIGN = &H0


Public Type POINTAPI
X As Long
Y As Long
End Type


Dim hMenu As Long

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

Const MF_STRING = &H0



Public Const SERVICE_NAME = "GKUPr"
Public Const INFINITE = -1&
Private Const WAIT_TIMEOUT = 258&

Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(1 To 128) As Byte
End Type

Public Const VER_PLATFORM_WIN32_NT = 2&

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

Public hStopEvent As Long, hStartEvent As Long, hStopPendingEvent As Long

Public IsNT As Boolean, IsNTService As Boolean
Public ServiceName() As Byte, ServiceNamePtr As Long

'Public hMakeHidWnd As Long, hCloseHidWnd As Long
'Public HidWndCreated As Boolean

Dim hHookKB As Long 'дескриптор клавиатурного хука
'Dim hHookMO As Long 'дескриптор мышиного хука
Dim last_hook_time As Date
Dim cTray As TrayIcon
Dim cTray_err As TrayIcon
Dim BDw As BD_work
Dim menu_arr() As String
Dim icon_switch As Byte 'это переключатель иконки (какая иконка на экране) при мигании
Dim timer_counter As Integer 'cчетчик таймеров при мониторинге
'Dim show_err As Boolean 'показана ошибка или нет
Dim tim_reg As Byte 'это режим работы таймера


Public m_lnghWnd As Long 'хэндл скрытого окна
Public m_lngOldWndProc As Long 'хэндл процедуры окна
'*****************************************************************


Private Sub Main()
On Error Resume Next
Dim cntr As Byte
Dim hnd As Long 'хэндл сервисного потока
Dim hnd2 As Long 'хэндл оконного потока
Dim h(0 To 1) As Long 'возвращаемый массив от сервисного потока
Dim h2(0 To 1) As Long 'возвращаемый массив от оконного потока
' чтоб не пустили 2 сеанса
If App.PrevInstance Then Exit Sub
'last_hook_time = Now
'hHookKB = SetWindowsHookEx(0, AddressOf HookProc, App.hInstance, 0)
If Command = "-install" Then
If SetNTService() = 0 Then
Shell ("net start " & SERVICE__NAME & " /s")
Else
MessageBox 0&, "Сервис не удалось установить.", "Внимание! Ошибка!", vbCritical Or vbOKOnly Or vbMsgBoxSetForeground
End If
End
ElseIf Command = "-uninstall" Then

If DeleteNTService() = 0 Then
MessageBox 0&, "Сервис успешно удален.", "Внимание!", vbInformation Or vbOKOnly Or vbMsgBoxSetForeground
Else
MessageBox 0&, "Сервис не удалось удалить.", "Внимание! Ошибка!", vbCritical Or vbOKOnly Or vbMsgBoxSetForeground
End If
End
End If
' проверка операционки
IsNT = CheckIsNT()
' события

hStopEvent = CreateEvent(0, 1, 0, vbNullString)
hStopPendingEvent = CreateEvent(0, 1, 0, vbNullString)
hStartEvent = CreateEvent(0, 1, 0, vbNullString)
'hMakeHidWnd = CreateEvent(0, 1, 0, vbNullString)
'hCloseHidWnd = CreateEvent(0, 1, 0, vbNullString)

ServiceName = StrConv(SERVICE_NAME, vbFromUnicode)
ServiceNamePtr = VarPtr(ServiceName(LBound(ServiceName)))
'Load ServiceMain

If IsNT Then
' пробуем стартануть сервис
hnd = StartAsService
h(0) = hnd
h(1) = hStartEvent
' ждем пока сервис стартанет (1) или обломает со стартом (0)
IsNTService = WaitForMultipleObjects(2&, h(0), 0&, INFINITE) = 1&
If Not IsNTService Then
CloseHandle hnd
MessageBox 0&, "Эта программа должна стартовать как сервис.", "Внимание! Ошибка!", vbCritical Or vbOKOnly Or vbMsgBoxSetForeground
End If
Else
MessageBox 0&, "Эта программа только для Windows NT/2000/XP.", "Внимание! Ошибка!", vbCritical Or vbOKOnly Or vbMsgBoxSetForeground
End If

If IsNTService Then
' ******************
' тут можно добавить сервисных обьектов
' ******************
Call MakeWnd

SetServiceState SERVICE_RUNNING
'App.LogEvent "Сервис стартанул"


'hnd2 = StartHiddenWindow
'h2(0) = hnd2
'h2(1) = hMakeHidWnd
'If WaitForMultipleObjects(2&, h2(0), 0&, INFINITE) = 1& Then
tim_reg = 0
cntr = 0
Do
' ******************
' весь фунционал складывать сюда
' цикл лупится раз в 100 миллисекунд
' ******************
DoEvents
If cntr = 10 Then
cntr = 0
Timer
Else
cntr = cntr + 1
End If

Loop While WaitForSingleObject(hStopPendingEvent, 100&) = WAIT_TIMEOUT

'End If



' ******************
' тут те обьекты, которые вверху добавил надо убивать
' ******************

'UnhookWindowsHookEx hHookKB
Call BDw.Write_shutdown
Call DestroyMenu(hMenu)
If BDw.have_er Then
Call cTray_err.Delete
End If
Call cTray.Delete
Call DestroyWindow(m_lnghWnd)

SetServiceState SERVICE_STOPPED
'App.LogEvent "Сервис остановился"
SetEvent hStopEvent
' ждем остановки сервиса
WaitForSingleObject hnd, INFINITE
CloseHandle hnd
End If
CloseHandle hStopEvent
CloseHandle hStartEvent
CloseHandle hStopPendingEvent
End Sub


сервисный модуль, работает во втором потоке (обработчики сообщений по возможности убрал)


Private Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private ServiceStatus As SERVICE_STATUS
Private hServiceStatus As Long

' The FncPtr function returns function pointer.
Function FncPtr(ByVal fnp As Long) As Long
FncPtr = fnp
End Function

' делает Service Dispatcher thread
Public Function StartAsService() As Long
Dim ThreadId As Long
StartAsService = CreateThread(0&, 0&, AddressOf ServiceThread, 0&, 0&, ThreadId)
End Function

' стартует сервис
' возвращает управление после остановки сервиса
Private Sub ServiceThread(ByVal dummy As Long)
Dim ServiceTableEntry As SERVICE_TABLE
ServiceTableEntry.lpServiceName = ServiceNamePtr
ServiceTableEntry.lpServiceProc = FncPtr(AddressOf ServiceMain)
StartServiceCtrlDispatcher ServiceTableEntry
End Sub

' основная процедура сервиса
' стартует сервис,
' устанавливает событие hStartEvent, и ждёт hStopEvent,
' когда дожидается, выходит из процедуры и сервис остаавливается
Private Sub ServiceMain(ByVal dwArgc As Long, ByVal lpszArgv As Long)
ServiceStatus.dwServiceType = SERVICE_WIN32_OWN_PROCESS
ServiceStatus.dwControlsAccepted = SERVICE_ACCEPT_STOP _
Or SERVICE_ACCEPT_SHUTDOWN
'ServiceStatus.dwControlsAccepted = SERVICE_ACCEPT_SHUTDOWN
ServiceStatus.dwWin32ExitCode = 0&
ServiceStatus.dwServiceSpecificExitCode = 0&
ServiceStatus.dwCheckPoint = 0&
ServiceStatus.dwWaitHint = 0&
hServiceStatus = RegisterServiceCtrlHandler(SERVICE_NAME, _
AddressOf Handler)
SetServiceState SERVICE_START_PENDING
' устанавливает событие hStartEvent и отпускает основной поток
SetEvent hStartEvent
' ждет hStopEvent
WaitForSingleObject hStopEvent, INFINITE
End Sub

' перехватывает команды сервисного диспетчера
' и генерит сбытие hStopEvent при обработке
' SERVICE_CONTROL_STOP или SERVICE_CONTROL_SHUTDOWN
Private Sub Handler(ByVal fdwControl As Long)
Select Case fdwControl
Case SERVICE_CONTROL_SHUTDOWN, SERVICE_CONTROL_STOP
SetServiceState SERVICE_STOP_PENDING
SetEvent hStopPendingEvent
Case Else
SetServiceState
End Select
End Sub

' меняет состояние сервиса
Public Sub SetServiceState(Optional ByVal NewState As SERVICE_STATE = 0&)
If NewState <> 0& Then ServiceStatus.dwCurrentState = NewState
SetServiceStatus hServiceStatus, ServiceStatus
End Sub


------------------
Best regards, _bob