㈠ 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中寫一函數，變相調用，結束後暫停線程，使之線程函數不返回