㈠ vb6.0源代码
你这里的RsAddUser是自己声明的ADODB.Recordset对象
在变量声明段，你应该可以找到
Dim RsAddUser As ADODB.Recordset
或者是
Private RsAddUser As ADODB.Recordset
而
RsAddUser.State是该对象的一个属性，用来返回其处于打开或关闭的状态。
㈡ VB6现有完整源代码如何编译成程序，急急急！！！有图
点击【开始】-【程序】-【Microsoft Visual Basic 6.0 中文版】-【Microsoft Visual Basic 6.0 中文版工具】-【Package & Deployment 向导】，在对话框点击【浏览】，选择工程文件，然后点击【打包】，接下来按要求一步一步设置即可。
㈢ VB 多线程下载 源码
VB本身没有多线程支持能力,
一般采用C/C++开发一个DLL,供VB使用.使VB看起来好像支持了多线程一样.
㈣ 用vb6可不可以设计多线程序的应用程序，如何实现
多线程是可以啊，只是不太安全，容易非法操作，
源代码如下：
窗体中的代码：
Option Explicit
'开始
Private Sub Command1_Click()
On Error Resume Next
With myThreadleft
.Initialize AddressOf Fillleft '传递过程地址给线程
.ThreadEnabled = True
End With
With myThreadright
.Initialize AddressOf Fillright
.ThreadEnabled = True
End With
With myThreadbottom
.Initialize AddressOf Fillbottom
.ThreadEnabled = True
End With
MsgBox "多线程正在运行...，看看图片框控件的变色效果！", 64, "信息"
'终止线程运行
Set myThreadleft = Nothing
Set myThreadright = Nothing
Set myThreadbottom = Nothing
End Sub
'结束
Private Sub Command2_Click()
Unload Me
End Sub
模块中的代码：
Option Explicit
'时间计数API
Private Declare Function GetTickCount Lib "kernel32" () As Long
'声明cls_thread类的对象变量
Public myThreadleft As New cls_thread, myThreadright As New cls_thread, myThreadbottom As New cls_thread
Sub Main()
Load Form1
Form1.Show
End Sub
Public Sub Fillleft()
Static Bkgcolor As Long
Dim LongTick As Long, Longcounter As Long
On Error Resume Next
For Longcounter = 0 To 3000
DoEvents
Bkgcolor = Longcounter Mod 256
Form1.Picture1.BackColor = RGB(Bkgcolor, 0, 0)
LongTick = GetTickCount
While GetTickCount - LongTick < 10 '延时10毫秒,下同
Wend
Next
Set myThreadleft = Nothing '如果循环结束则终止当前线程运行，下同
End Sub
Public Sub Fillright()
Static Bkgcolor As Long
Dim LongTickValue As Long, Longcounter As Long
On Error Resume Next
For Longcounter = 0 To 3000
DoEvents
Bkgcolor = Longcounter Mod 256
Form1.Picture2.BackColor = RGB(0, Bkgcolor, 0)
LongTickValue = GetTickCount
While GetTickCount - LongTickValue < 10
Wend
Next
Set myThreadright = Nothing
End Sub
Public Sub Fillbottom()
Static Bkgcolor As Long
Dim LongTick As Long, Longcounter As Long
On Error Resume Next
For Longcounter = 0 To 3000
DoEvents
Bkgcolor = Longcounter Mod 256
Form1.Picture3.BackColor = RGB(0, 0, Bkgcolor)
LongTick = GetTickCount
While GetTickCount - LongTick < 10
Wend
Next
Set myThreadright = Nothing
End Sub
类模块中的代码：
'功能：创建多线程类，用于初始化线程。 类名：cls_Thread
'参数：LongPointFunction 用于接收主调过程传递过来的函数地址值
'调用方法：1.声明线程类对象变量 Dim mythread as cls_Thread
' 2.调用形式：With mythread
' .Initialize AddressOf 自定义过程或函数名 '(初始化线程) .
' .ThreadEnabled = True '(设置线程是否激活)
' End With
' 3.终止调用： Set mythread = Nothing
' Crate By : 陈宇 On 2004.5.10 Copyright(C).Ldt By CY-soft 2001--2004
' Email:[email protected]
' Test On： VB6.0+Win98 AND VB6.0+WinXP It's Pass ！
Option Explicit
'创建线程API
'此API经过改造，lpThreadAttributes改为Any型，lpStartAddress改为传值引用：
'因为函数的入口地址由形参变量传递，如果用传址那将传递形参变量的地址而不是函数的入口地址
Private Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, LpthreadId As Long) As Long
'终止线程API
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
'激活线程API
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
'挂起线程API
Private Declare Function SuspendThread Lib "kernel32" (ByVal hThread As Long) As Long
Private Const CREATE_SUSPENDED = &H4 '线程挂起常量
'自定义线程结构类型
Private Type udtThread
Handle As Long
Enabled As Boolean
End Type
Private meTheard As udtThread
'初始化线程
Public Sub Initialize(ByVal LongPointFunction As Long)
Dim LongStackSize As Long, LongCreationFlags As Long, LpthreadId As Long, LongNull As Long
On Error Resume Next
LongNull = 0
LongStackSize = 0
LongCreationFlags = CREATE_SUSPENDED '创建线程后先挂起，由程序激活线程
'创建线程并返线程句柄
meTheard.Handle = CreateThread(LongNull, LongStackSize, ByVal LongPointFunction, LongNull, LongCreationFlags, LpthreadId)
If meTheard.Handle = LongNull Then
MsgBox "线程创建失败！", 48, "错误"
End If
End Sub
'获取线程是否激活属性
Public Property Get ThreadEnabled() As Boolean
On Error Resume Next
Enabled = meTheard.Enabled
End Property
'设置线程是否激活属性
Public Property Let ThreadEnabled(ByVal Newvalue As Boolean)
On Error Resume Next
'若激活线程（Newvalue为真）设为TRUE且此线程原来没有激活时激活此线程
If Newvalue And (Not meTheard.Enabled) Then
ResumeThread meTheard.Handle
meTheard.Enabled = True
Else '若激活线程（Newvalue为真）且此线程原来已激活则挂起此线程
If meTheard.Enabled Then
SuspendThread meTheard.Handle
meTheard.Enabled = False
End If
End If
End Property
'终止线程事件
Private Sub Class_Terminate()
On Error Resume Next
Call TerminateThread(meTheard.Handle, 0)
End Sub
㈤ vb6如何运行代码时不死机
循环中插入doevents语句。如果是VB.net，要写成 application.doevents()。
Command1.Caption = "请稍候"
Command1.Enabled = False
这两句后也插入doevents语句。
还有shell语句好像有个 "等待" 什么的，就是要等到shell的那个程序关闭，shell后的语句才能继续。
看看shell的参数是否可以设置不要等待。
那个inet控件问题，精简版的VB就不知道怎么搞了。但是客户端的问题应该很简单，在你那个非精简版的VB上打包安装包给客户端安装就可以了
㈥ vb6 无驱摄像头编程 求源码
发下是我几年前写的(参照)一个VB驱动摄像头的代码,不知道现在还能不能用,因为文件总的很长,这只是其中的一小部分,希望对你有所用.(要不就和我联系,给你源码)
Private Sub Form_Load()
On Error Resume Next
Dim retVal As Boolean
Dim numDevs As Long
bCaramaPlaying = True
'load trivial settings first
Me.BackColor = Val(GetSetting(App.Title, "preferences", "backcolor", "&H404040")) 'default to dk gray
numDevs = VBEnumCapDrivers(Me)
If 0 = numDevs Then
MsgBox "没有找到视频捕捉设备!", vbCritical, App.Title
' frmPlayer.Visible = True
' If bIsVisible = True And vbPlayFormIsVisible = True And vbFrmPlayFrameHided = False Then
' frmPlayFrame.Visible = True
' End If
Unload Me
Exit Sub
End If
nDriverIndex = Val(GetSetting(App.Title, "driver", "index", "0"))
'if invalid entry is in registry use default (0)
If mnuDriver.UBound < nDriverIndex Then
nDriverIndex = 0
End If
mnuDriver(nDriverIndex).Checked = True
'//Create Capture Window
'Call capGetDriverDescription( nDriverIndex, lpszName, 100, lpszVer, 100 '// Retrieves driver info
hCapWnd = capCreateCaptureWindow("VB CAP WINDOW", WS_CHILD Or WS_VISIBLE, 0, 0, 160, 120, Me.hWnd, 0)
If 0 = hCapWnd Then
MsgBox "不能创建捕捉窗口!", vbCritical, App.Title
Exit Sub
End If
retVal = ConnectCapDriver(hCapWnd, nDriverIndex)
If False = retVal Then
MsgBox "不能连接到视频设备!", vbInformation, App.Title
Else
#If USECALLBACKS = 1 Then
' if we have a valid capwnd we can enable our status callback function
Call capSetCallbackOnStatus(hCapWnd, AddressOf StatusProc)
Debug.Print "---Callback set on capture status---"
#End If
End If
'// Set the video stream callback function
' capSetCallbackOnVideoStream lwndC, AddressOf MyVideoStreamCallback
' capSetCallbackOnFrame lwndC, AddressOf MyFrameCallback
Dim bPlayFrameTop As Boolean
bPlayFrameTop = GetSetting(MyName, "setting" & "-" & Trim(Str(App.Major)) & "-" & Trim(Str(App.Minor)), "bPlayFrameTop", "False")
If bPlayFrameTop = True Then
Me.mnuOptionTop.Checked = True
'放在最前
SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, Me.Top / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, &H20
Else
Me.mnuOptionTop.Checked = False
'不放在最前
SetWindowPos Me.hWnd, HWND_NOTOPMOST, Me.Left / Screen.TwipsPerPixelX, Me.Top / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, &H20
End If
Me.Left = (Screen.Width - Me.Width) / 2
Me.Top = (Screen.Height - Me.Height) / 2
Me.picShowMenu.ZOrder 0
End Sub
'以下是一个模块文件
Option Explicit
'application specific routines are here
Public Const ONE_MEGABYTE As Long = 1048576
'Public Const MMSYSERR_NOERROR As Long = 0
Public Const INDEX_15_MINUTES As Long = 27000 '(30fps * 60sec * 15min)
Public Const INDEX_3_HOURS As Long = 324000 ' (30fps * 60sec * 60min * 3hr)
Public Function GetFreeSpace() As Long
'this function gets the amount of free disk space and adds the size
'of the current capture file
Dim freedisk As Long
Dim path As String
'get Cap File length
path = capFileGetCaptureFile(frmCaramaMain.capwnd)
If path <> "" Then
On Error Resume Next
freedisk = FileLen(path)
freedisk = freedisk / ONE_MEGABYTE
End If
'now get free disk space from that drive
path = Left$(path, 3)
GetFreeSpace = freedisk + vbGetAvailableMBytes(path)
End Function
Sub ResizeCaptureWindow(ByVal hCapWnd As Long)
Dim retVal As Boolean
Dim capStat As CAPSTATUS
'Get the capture window attributes
retVal = capGetStatus(hCapWnd, capStat)
If retVal Then
'Resize the main form to fit
Call SetWindowPos(frmCaramaMain.hWnd, _
0&, _
0&, _
0&, _
capStat.uiImageWidth + (frmCaramaMain.XBorder * 2), _
capStat.uiImageHeight + (frmCaramaMain.YBorder * 4) _
+ frmCaramaMain.CaptionHeight + frmCaramaMain.MenuHeight, _
Swp_nomove Or SWP_NOZORDER Or SWP_NOSENDCHANGING)
'Resize the capture window to format size
Call SetWindowPos(hCapWnd, _
0&, _
0&, _
0&, _
capStat.uiImageWidth, _
capStat.uiImageHeight, _
Swp_nomove Or SWP_NOZORDER Or SWP_NOSENDCHANGING)
End If
Call frmCaramaMain.Form_Resize
End Sub
Public Function VBEnumCapDrivers(ByRef frm As frmCaramaMain) As Long
'/*
' * Enumerate the potential capture drivers and add the list to the Options
' * menu. This function is only called once at startup.
' * Returns 0 if no drivers are available.
' */
Const MAXVIDDRIVERS As Long = 9
Const CAP_STRING_MAX As Long = 128
Dim numDrivers As Long
Dim driverStrings(0 To MAXVIDDRIVERS - 1) As String
Dim Index As Long
Dim Device As String
Dim Version As String
Dim menu As VB.menu
Device = String$(CAP_STRING_MAX, 0)
Version = String$(CAP_STRING_MAX, 0)
numDrivers = 0
For Index = 0 To (MAXVIDDRIVERS - 1) Step 1
If 0 <> capGetDriverDescription(Index, _
Device, _
CAP_STRING_MAX, _
Version, _
CAP_STRING_MAX) _
Then
'extend the menu
If Index > 0 Then
Load frm.mnuDriver(Index)
End If
Set menu = frm.mnuDriver(Index) 'get an object pointer to the new menu
'Concatenate the device name and version strings to the new menu item
menu.Caption = Left$(Device, InStr(Device, vbNullChar) - 1)
menu.Caption = menu.Caption & " "
menu.Caption = menu.Caption & Left$(Version, InStr(Version, vbNullChar) - 1)
menu.Enabled = True
numDrivers = numDrivers + 1
End If
Next
VBEnumCapDrivers = numDrivers
End Function
Public Function ConnectCapDriver(ByVal hCapWnd As Long, ByVal nDriverIndex As Long) As Boolean
Dim retVal As Boolean
Dim Caps As CAPDRIVERCAPS
Dim i As Long
Debug.Assert (nDriverIndex < 10) And (nDriverIndex >= 0)
'// Connect the capture window to the driver
retVal = capDriverConnect(hCapWnd, nDriverIndex)
If False = retVal Then
'return False
Exit Function
End If
'// Get the capabilities of the capture driver
retVal = capDriverGetCaps(hCapWnd, Caps)
If False <> retVal Then
'reset menus (very app-specific)
With frmCaramaMain
For i = 0 To .mnuDriver.UBound
.mnuDriver(i).Checked = False 'make sure all drivers are unchecked
Next
.mnuDriver(nDriverIndex).Checked = True 'then check the new driver
'disable all hardware feature menu items
.mnuSource.Enabled = False
.mnuFormat.Enabled = False
.mnuDisplay.Enabled = False
.mnuOverlay.Enabled = False
'Then enable the ones which are supported by the new driver
If Caps.fHasDlgVideoSource <> 0 Then .mnuSource.Enabled = True
If Caps.fHasDlgVideoFormat <> 0 Then .mnuFormat.Enabled = True
If Caps.fHasDlgVideoDisplay <> 0 Then .mnuDisplay.Enabled = True
If Caps.fHasOverlay <> 0 Then .mnuOverlay.Enabled = True
End With
End If
'// Set the preview rate in milliseconds
Call capPreviewRate(hCapWnd, 66) '15 FPS
'// Start previewing the image from the camera
Call capPreview(hCapWnd, True)
'default to showing a preview each time
frmCaramaMain.mnuPreview.Checked = True
'// Resize the capture window to show the whole image
Call ResizeCaptureWindow(hCapWnd)
ConnectCapDriver = True
End Function
Public Function StatusProc(ByVal hCapWnd As Long, ByVal StatusCode As Long, ByVal lpStatusString As Long) As Long
Select Case StatusCode
Case 0 'this is recommended in docs
'when zero is sent, clear old status messages
'frmCaramaMain.Caption = App.Title
Case IDS_CAP_END ' Video Capture has finished
frmCaramaMain.Caption = App.Title
Case IDS_CAP_STAT_VIDEOAUDIO, IDS_CAP_STAT_VIDEOONLY
MsgBox LPSTRtoVBString(lpStatusString), vbInformation, App.Title
Case Else
'use this function if you need a real VB string
'frmCaramaMain.Caption = LPSTRtoVBString(lpStatusString)
'or, just pass the LPCSTR to a WINAPI function
Call SetWindowTextAsLong(frmCaramaMain.hWnd, lpStatusString)
End Select
Debug.Print "Driver returned code " & StatusCode & " to StatusProc"
StatusProc = -(True) '- converts Boolean to C BOOL
End Function
㈦ 如何在VB6里面实现稳定的多线程
微软官方给出的方案在MSDN里面有说,就是使用ActiveX EXE那种"单元线程模型".
我也曾经试过,的确可以实现"多线程",只是由于要多一个EXE,比较麻烦,后来就没有深入了.
结果一次无意中在VBGOOD中看到一段代码,才打通了一个关节:为什么不直接使用ActiveX EXE写程序呢?!
那段代码里面,是直接使用这种工程类型,然后在工程内使用CreateObject来生成一个新对象,这样的话,新的对象就工作于一个单元线程内了.
其实这个我也知道,可是就没有想到在ActiveX EXE内部使用
看来思路真的不如人.....还要多多学习,多多积累.
ActiveX EXE工程设置为"独立启动"后,貌似只能从Sub Main里进行初始化.
而每个对象的建立,都会调用一次这个过程,因此这个过程需要一次性运行.
但是MSDN里说得很清楚,在单元线程模型里面,全局变量的范围只能是本单元,因此不能使用设置全局变量来完成这个过程的一次运行逻辑.
原代码里使用了GetProp等方式,感觉不是很好,于是作了一下改进,使用事件对象来完成此工作.
Sub Main相关代码如下:
Private Const MyEvent As String = "m5home"
Dim hEvent As Long
Sub Main()
If GetEventHandle = 0 Then '由于每个新对象的建立,都要执行Main()过程,因此使用事件对象来进行判断.
hEvent = CreateEvent(0&, False, False, MyEvent) '在单元线程下,模块里的全局变量已经没有用了.frmMain.Show
End If
End Sub
Private Function GetEventHandle() As Long
GetEventHandle = OpenEvent(EVENT_ALL_ACCESS, False, MyEvent)
Call CloseHandle(GetEventHandle)
End Function
Public Function Quit()
Call CloseHandle(hEvent)
End Function
Private Const MyEvent As String = "m5home"
Dim hEvent As Long
Sub Main() If GetEventHandle = 0 Then '由于每个新对象的建立,都要执行Main()过程,因此使用事件对象来进行判断.
hEvent = CreateEvent(0&, False, False, MyEvent) '在单元线程下,模块里的全局变量已经没有用了.frmMain.Show
End If
End Sub
Private Function GetEventHandle() As Long GetEventHandle = OpenEvent(EVENT_ALL_ACCESS, False, MyEvent)
Call CloseHandle(GetEventHandle)
End Function
Public Function Quit()
Call CloseHandle(hEvent)
End Function
由于事件对象是系统范围的,因此可以比较完美的完成这个工作.
同时事件对象在进程消失后,会自动释放,也方便:)
示例代码可以生成一个新的单元线程,并在这个线程里面显示一个窗体,窗体进行一个大循环.
循环内没有放入DoEvents函数,因此会造成循环所在窗体无响应.
而此时主窗体不受影响.
㈧ VB如何实现多线程
用CreateThread API函数根本无法实现VB6多线程！虽然系统提供了这个API函数，但是这种实现方法对VB6程序极其不稳定，容易出现非法操作。如果确实需要多线程的话，请使用控件，此处可以下载MThreadVB
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=26900&lngWId=1
打字不易，如满意，望采纳。
㈨ vb6 怎样获取网页源码
这个用INET控件比较简单
最简便的方法：
首先添加一个INET控件，命名为INET1
添加一个按钮控件，command1
添加一个TEXT控件,用来存放源码
private sub command1_click()
Text1.Text = Inet1.OpenURL("http://www..com")
end sub
㈩ 怎么在vb6.0中声明多线程并且使用多线程请高手们给个例子,在下感谢不尽!
其实告诉你一点吧，VB6.0不支持多线程，（指的是线程函数返回后必定Error，除非线程函数不在VB中，而且不能在程序结束前返回） ，本人多种方法尝试，无效，只有一种方法奏效，在C中写一函数，变相调用，结束后暂停线程，使之线程函数不返回