李倓剧情怎么开:Visual Basic编程疑难问题解(一)(二)

Visual Basic编程疑难问题解(一)(二)

［前言：］在这个专题中我收集了一些在Visual Basic编程中的常见问题，这些问题均来自论坛，本专题以解决实际问题主要目的。

　　问：VB中如何使用C++类？

　　答：把vc的类编译成dll文件，这样的话就可以使用，最好是作为组件com来使用。

　　VB调用DLL的方法和调用Windows API的方法是一样的，一般在VB的书中有介绍。对于上面一个例子，先要声明VC函数：

Declare Function sample Lib "mydll.dll" (ByVal nLen As Integer, buffer As Integer) As Integer

　　这里mydll.dll是你的dll的名字。你可能已经注意到了两个参数的声明有所不同，第一个参数加上了ByVal。规则是这样的：如果在VC中某个参数声明为指针和数组，就不加ByVal，否则都要加上ByVal。在VB中调用这个函数采用这样的语法：

    sample 10, a(0)

　　这里的a()数组是用来存放数据的，10为数组长度，这里的第二个参数不能是a()，而必须是要传递的数据中的第一个。这是VB编程的关键。

　　下面在说几个可能遇到的问题。一个问题是VB可能报告找不到dll，你可以把dll放到system目录下，并确保VB的Declare语句正确。另一个问题是VB报告找不到需要的函数，这通常是因为在VC中*.def文件没设置。第三种情况是VB告诉不能进行转换，这可能是在VC中没有加上__stdcall关键字，也可能是VB和VC的参数类型不一致，注意在VC中int是4个字节(相当于VB的Long)，而VB的Integer只有2个字节。必须保证VB和VC的参数个数相同，所占字节数也一致。最后一个要注意的问题是VC中绝对不能出现数组越界的情况，否则会导致VB程序崩溃。

　　问：怎样用编程方式在窗体上创建一个label或textbox？

答:代码如下:

'声明

Private WithEvents NewButton As ComandButton

'1,添加

Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Me)

NewButton.Move 0, 0, Width, Height

NewButton.Visible = True

'2，删除

Controls.Remove NewButton

Set NewButton = Nothing

　　问：如何把一个已编译的EXE程序打包到VB中再编译呢？

　　答：你需要先编写一个程序B，并将其编译为EXE。如果你希望今后允许程序A定制程序B的某个文本框，可以先将该文本框的Caption属性设置为“Change Me!Change Me!”之类首先定义好的字符串。然后程序A以二进制方式打开程序B，然后在其中查找“Change Me!Change Me!”字符串，并将其改变为程序A中设置的文字。但这种方法有几个缺点：

　　1、字符串长度有限；

　　2、对于VB来说，编译后有的中文字符串编译后格式有些办法，不好处理。

　　也可以采用另一种办法。程序A将设置信息保存在程序B文件的尾部。用程序B以二进制方式打开其自己的EXE文件，利用Seek命令移动到指定位置读出设置信息。如：

Dim s As String * 100

On Error GoTo ErrHandler

Open App.Path + "\" + App.EXEName + ".EXE" For Binary As #1

Seek 1, 20480 ' 这里是EXE文件的长度

Get 1, , s

Label1.Caption = s

Close #1

Exit Sub

　　问：如何确定EXE文件的长度的具体数值呢？

　　答：先编译程序B，看看程序B的EXE文件的长度，例如17234。然后将上面的20480改为17234，再编译一次程序B。

问：关于程序热键公用问题？

　　如果两个程序都用到了相同的热键 比如说ctrl+enter 当这2个程序同时运行起来的时候，怎么才能让只有一个程序接受热键，换句话说就是谁在前台（前面 激活状态）谁就使用这个热键，谁在后台 或者最小化等非激活状态 那么就不使用这个热键！ 怎么能做到呢？

答:代码如下:

Private Sub Text2_KeyDown(KeyCode As Integer, Shift As Integer)

If Shift = 2 Then

If KeyCode = vbKeyReturn Then

Text1.Text = Text2.Text

Text2.Text = ""

End If

End If

End Sub

　　问：在用二进制binary,写入一个字串时(比如"你好")后，如何用get读出来？

　　答：在VB读和写有专用的语法，或者直接使用FSO，如：

Open 文件所在路径 For Output As #1

Write #1, "你好"

Close (1)

'这是写文件操作

读的话类同，用line input读出来就可以了。

　　问：怎样让Listbox中的滚动条的颜色与Listbox的背景颜色一致？

　　答：其实要看每个控件是否可以设置颜色，一般检查一下控件的backcorlor和forecolor属性就可以了，有的话，自己设置吧。

　　问：怎么让form时刻处于最上方，formName.show不能做到这一点?

答:代码如下:

Private 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

Private Const HWND_TOPMOST = -1

Private Const SWP_NOMOVE = &H2

Private Const SWP_NOSIZE = &H1

Private Sub Form_Load()

SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, Me.Width, Me.Height, SWP_NOMOVE Or SWP_NOSIZE

End Sub

　　问：定义在类中的Procedure和Function有什么区别？ 他们是不是都可以单独存在?

　　答：procedure是声明一个过程,没有返回值.

　　function是声明一个函数,有返回值的.

　　问：VB中在textbox中查找单个的字符或字符串有什么好方法? 如:

在textbox中查找: 如textbox.text="12345678"查找"78"或"8" 代码怎么写?

答:用instr函数

例:

Dim i As Integer

Text1.Text = "12345678"

i=instr(text1.text,"78"

　　i 的值就是在textBox中找到的字符串"78"的第一次出现的位置.

问： 怎样判断程序是否在运行，如果运行怎样关闭他呢？

　　答：先用findwindow得到你要查的窗口的hwnd，然后用sendmessge yourform.hwnd,wm_close,0

Private button1_click()

Dim tmp As Long

tmp = findwindow(vbNullString, "程序的窗口名VB中FORM的NAME属性值")

If tmp > 0 Then

SendMessage tmp, wm_close, 0

Else

MsgBox "Sorry!Don't find formname"

End If

End Sub

　　问：如何用vb实现真正的多线程而不是多进程？

　　答：1.最好把代码放在Active Dll里，编译时使用p代码方式,至少要装vbsp3以上

　　　　2.线程函数里不能有VB的内置函数，比如left,trim等

　　　　3.创建线程CreateThread的参数不要使用ByVal &0,使用变量

　　　　主程序退出时要使用TerminateProcess(GetCurrentProcess, ByVal 0&)强行结束当前进程，否则有可能出错，这是两个API函数，请查相关资料

　　问：局域网点对点传输，如何数据加密？怎样实现？

　　答：在text1中输入你要加密的数据（16进制）

   将它和4E进行异或

   再按就把数据还原了

Private Sub Command1_Click()

tmp = Hex(Val("&H" & Text1.Text) Xor Val("&H" & "4E"))

Text1.Text = tmp

End Sub

　　问：如何实现鼠标取词？

'所要用到的函数、常量、类型

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function WindowFromPoint Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Const WM_GETTEXT = &HD

Private Const WM_SETTEXT = &HC

Private Type POINTAPI

x As Long

y As Long

End Type

Private Sub Form_Load()

End Sub

Private Sub Timer1_Timer()

'

' 代码就是这么简单，你好好研究一下吧。

'

'

Dim Shu As POINTAPI

Dim str As String * 300

GetCursorPos Shu

SendMessage WindowFromPoint(Shu.x, Shu.y), WM_GETTEXT, 299, ByVal str

Label1.Caption = str

End Sub

　　根据代码加入相应控件，timer1的interval的属性为100再加入把当前窗口置顶就是一个完美的简单的取词工具了！

　　问：VB调DLL时，如何传Structure？

　　答：在DLL里定义时应该用指针作参数，在VB里面，只要把结构变量定义成 Long 类型就可以了，调用的时候传入地址，就是在调用的时候，在参数前面加 ByVal。

问: 如何可以在VB中实现对整个系统鼠标和键盘的屏蔽

　　答：我们常见一些导览系统或教学系统，会自动移动Mouse与Keyin字，而那个时候，我们不管Keyin或动Mouse都没有效，直到完成了导览系统的某个动作後才让使用者可以移动Mouse与做Keyin的动作；想做到这个，要借重JournalPlayBack Hook。

　　JournalPlayBack Hook，它和JournalRecord Hook合称Journal Hook，它们作用范围是整个System，也就是挂上这个Hook後，影响的层面不单是这个Process，而是有的Process，而这两Hook又不用写在Dll之中，所以很好用。

　　首先我们要知道由键盘和Mouse输入等的硬体讯息，会存到一个System Queue而後OS会该System Queue看有没有讯息在其中，若有则撷取出来，看目前Active的Window是谁将讯息Post给它。而挂上JournalRecord Hook时，当有讯息被撷取出来时，会先执行他们所设定的Hook Function(在vb中，一定要放在.BAS档之中)。这可以做什麽事呢？

　　例如我们可以Check整个系统是否有按了键盘或有没有移动Mouse(一般来说，KeyUp,KeyDown, MouseMove等Event只有Form在Active 时才收得到，挂上JournalRecord hook後，执行Hook的thread便能收到所有这些讯息)。再如，它既然能收到Keyboard、Mouse的讯息，那便可以将收到的讯息记录起来(记录於Memory或Disk都可以)，之後再依方才的顺序重新将讯息放送出来，可重新执行方才的动作(这不就是巨集的作法吗)，或许它叫JournalRecord便是这个原因。再来便是播放记录讯息的问题了，如果一面播放，一面有其他讯息插队(如移动Mouse)，那就不对了，所以JournalPlayBack这个Hook它会让Mouse、Keyboard都失效，当OS 要求读System Queue时，便会启动这个Hook，就在此时，我们可以把方才记录起来的讯息丢出一个出来，OS再要求读System Queue时，再丢下一个讯息，如此达重播的效果(所以才叫JournalPlayBack)，正因它会让键盘、Mouse失效，拿它来做导览、教学系统的自动Move Mouse或文字显示是最适合的了。

　　Mouse的自动导引系统制作方式，可叁考如何自动移动Mouse

'以下在.Bas中

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Const WM_MOUSELAST = &H209

Const WM_MOUSEFIRST = &H200

Public Const WM_KEYLAST = &H108

Public Const WM_KEYFIRST = &H100

Public Const WH_JOURNALRECORD = 0

Public Const WH_JOURNALPLAYBACK = 1

Type EVENTMSG

message As Long

paramL As Long

paramH As Long

time As Long

hwnd As Long

End Type

Declare Function SetWindowsHookEx Lib "user32" Alias _

"SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _

ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Declare Function UnhookWindowsHookEx Lib "user32" _

(ByVal hHook As Long) As Long

Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _

ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Public hNxtHook As Long ' handle of Hook Procedure

Public msg As EVENTMSG

Sub EnableHook()

hNxtHook = SetWindowsHookEx(WH_JOURNALPLAYBACK, AddressOf HookProc, App.hInstance, 0)

End Sub

Sub FreeHook()

Dim ret As Long

ret = UnhookWindowsHookEx(hNxtHook)

End Sub

Function HookProc(ByVal code As Long, ByVal wParam As Long, _

ByVal lParam As Long) As Long

HookProc = CallNextHookEx(hNxtHook, code, wParam, lParam)

End Function

'以下在Form中，需求:一个Command1, 一个text1

Private Sub Command1_Click()

Dim str5 As String, len5 As Long, i As Long

Call EnableHook

str5 = "这是一个测试JournalPlayBackHook的程式"

len5 = Len(str5)

For i = 1 To len5

Text1.Text = Mid(str5, 1, i)

Text1.Refresh

Sleep (200)

Next

Call FreeHook

End Sub

　　问：如何把picture控件中图形数据写成“流”？

答:可以使用adodb.stream对象?

　　上传图片或显示SWF的时候都希望得到它的高度和宽度，基本原理使用Adodb.Stream读二进制文件然后进行解析，然后返回一数组：

　　第一个元素为类型(BMP JPG PNG GIF SWF)

　　第二个元素为宽度{width}

　　第三个元素为高度{height}

　　第四个元素为width={width},height={height}式字符串

Class qswhImg

Dim aso

Private Sub Class_Initialize()

Set aso = CreateObject("Adodb.Stream")

aso.Mode = 3

aso.Type = 1

aso.Open

End Sub

Private Sub Class_Terminate()

Set aso = Nothing

End Sub

Private Function Bin2Str(bin)

Dim i, str

For i = 1 To LenB(bin)

clow = MidB(bin, i, 1)

If AscB(clow) < 128 Then

str = str & Chr(AscB(clow))

Else

i = i + 1

If i <= LenB(bin) Then str = str & Chr(AscW(MidB(bin, i, 1) & clow))

End If

Next

Bin2Str = str

End Function

Private Function Num2Str(num, base, lens)

'qiushuiwuhen (2002-8-12)

Dim ret

ret = ""

While (num >= base)

ret = (num Mod base) & ret

num = (num - num Mod base) / base

Wend

Num2Str = Right(String(lens, "0") & num & ret, lens)

End Function

Private Function Str2Num(str, base)

'qiushuiwuhen (2002-8-12)

Dim ret

ret = 0

For i = 1 To Len(str)

ret = ret * base + CInt(Mid(str, i, 1))

Next

Str2Num = ret

End Function

Private Function BinVal(bin)

'qiushuiwuhen (2002-8-12)

Dim ret

ret = 0

For i = LenB(bin) To 1 Step -1

ret = ret * 256 + AscB(MidB(bin, i, 1))

Next

BinVal = ret

End Function

Private Function BinVal2(bin)

'qiushuiwuhen (2002-8-12)

Dim ret

ret = 0

For i = 1 To LenB(bin)

ret = ret * 256 + AscB(MidB(bin, i, 1))

Next

BinVal2 = ret

End Function

Function getImageSize(filespec)

'qiushuiwuhen (2002-9-3)

Dim ret(3)

aso.LoadFromFile (filespec)

bFlag = aso.Read(3)

Select Case Hex(BinVal(bFlag))

Case "4E5089":

aso.Read (15)

ret(0) = "PNG"

ret(1) = BinVal2(aso.Read(2))

aso.Read (2)

ret(2) = BinVal2(aso.Read(2))

Case "464947":

aso.Read (3)

ret(0) = "GIF"

ret(1) = BinVal(aso.Read(2))

ret(2) = BinVal(aso.Read(2))

Case "535746":

aso.Read (5)

binData = aso.Read(1)

sConv = Num2Str(AscB(binData), 2, 8)

nBits = Str2Num(Left(sConv, 5), 2)

sConv = Mid(sConv, 6)

while(len(sConv) binData=aso.Read(1)

sConv=sConv&Num2Str(ascb(binData),2 ,8)

Wend

ret(0) = "SWF"

ret(1) = Int(Abs(Str2Num(Mid(sConv, 1 * nBits + 1, nBits), 2) - Str2Num(Mid(sConv, 0 * nBits + 1, nBits), 2)) / 20)

ret(2) = Int(Abs(Str2Num(Mid(sConv, 3 * nBits + 1, nBits), 2) - Str2Num(Mid(sConv, 2 * nBits + 1, nBits), 2)) / 20)

Case "FFD8FF":

Do

Do: p1 = BinVal(aso.Read(1)): Loop While p1 = 255 And Not aso.EOS

If p1 > 191 And p1 < 196 Then Exit Do Else aso.Read (BinVal2(aso.Read(2)) - 2)

Do: p1 = BinVal(aso.Read(1)): Loop While p1 < 255 And Not aso.EOS

Loop While True

aso.Read (3)

ret(0) = "JPG"

ret(2) = BinVal2(aso.Read(2))

ret(1) = BinVal2(aso.Read(2))

Case Else:

If Left(Bin2Str(bFlag), 2) = "BM" Then

aso.Read (15)

ret(0) = "BMP"

ret(1) = BinVal(aso.Read(4))

ret(2) = BinVal(aso.Read(4))

Else

ret(0) = ""

End If

End Select

ret(3) = "width=""" & ret(1) & """ height=""" & ret(2) & """"

getImageSize = ret

End Function

End Class

    使用范例 (读某目录下所有图片的宽度):

Set qswh = New qswhImg

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.GetFolder(server.mappath("."))

Set fc = f.Files

For Each f1 In fc

ext = fso.GetExtensionName(f1.Path)

Select Case ext

Case "gif", "bmp", "jpg", "png":

arr = qswh.getImageSize(f1.Path)

response.Write ""

" & arr(0) & " " & arr(3) & ":" & f1.name & " width:" & arr(1) & " height:" & arr(2)

Case "swf"

arr = qswh.getImageSize(f1.Path)

response.Write ""

" & arr(0) & " " & arr(3) & ":" & f1.name & " width:" & arr(1) & " height:" & arr(2)

End Select

Next

Set fc = Nothing

Set f = Nothing

Set fso = Nothing

Set qswh = Nothing

Visual Basic编程疑难问题解(二)

问题一：Visual Basic 导出到 Excel 提速之法

办法如下:

Excel 是一个非常优秀的报表制作软件，用VBA可以控制其生成优秀的报表，本文通过添加查询语句的方法，即用Excel中的获取外部数据的功能将数据很快地从一个查询语句中捕获到EXCEL中,比起往每个CELL里写数据的方法提高许多倍。

将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中

Public Function ExporToExcel(strOpen As String)

'*********************************************************

'* 名称：ExporToExcel

'* 功能：导出数据到EXCEL

'* 用法：ExporToExcel(sql查询字符串)

'*********************************************************

Dim Rs_Data As New ADODB.Recordset

Dim Irowcount As Integer

Dim Icolcount As Integer

Dim xlApp As New Excel.Application

Dim xlBook As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim xlQuery As Excel.QueryTable

With Rs_Data

If .State = adStateOpen Then

.Close

End If

.ActiveConnection = Cn

.CursorLocation = adUseClient

.CursorType = adOpenStatic

.LockType = adLockReadOnly

.Source = strOpen

.Open

End With

With Rs_Data

If .RecordCount < 1 Then

MsgBox ("没有记录!")

Exit Function

End If

'记录总数

Irowcount = .RecordCount

'字段总数

Icolcount = .Fields.Count

End With

Set xlApp = CreateObject("Excel.Application")

Set xlBook = Nothing

Set xlSheet = Nothing

Set xlBook = xlApp.Workbooks().Add

Set xlSheet = xlBook.Worksheets("sheet1")

xlApp.Visible = True

'添加查询语句，导入EXCEL数据

Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

With xlQuery

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.BackgroundQuery = True

.RefreshStyle = xlInsertDeleteCells

.SavePassword = True

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.PreserveColumnInfo = True

End With

xlQuery.FieldNames = True '显示字段名

xlQuery.Refresh

With xlSheet

.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.name = "黑体"

'设标题为黑体字

.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True

'标题字体加粗

.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous

'设表格边框样式

End With

With xlSheet.PageSetup

.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc

.CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&"

"宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："

.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："

.LeftFooter = "&""楷体_GB2312,常规""&10制表人："

.CenterFooter = "&""楷体_GB2312,常规""&10制表日期："

.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"

End With

xlApp.Application.Visible = True

Set xlApp = Nothing '"交还控制给Excel

Set xlBook = Nothing

Set xlSheet = Nothing

End Function

注: 须在程序中引用 'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000

本程序在Windows 98/2000,VB 6 下运行通过。

问题二: vb中从域名得到IP及从IP得到域名

办法如下:

Private Const WS_VERSION_REQD = &H101

Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&

Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&

Private Const MIN_SOCKETS_REQD = 1

Private Const SOCKET_ERROR = -1

Private Const WSADescription_Len = 256

Private Const WSASYS_Status_Len = 128

Private Type HOSTENT

hname As Long

hAliases As Long

hAddrType As Integer

hLength As Integer

hAddrList As Long

End Type

Private Type WSADATA

wversion As Integer

wHighVersion As Integer

szDescription(0 To WSADescription_Len) As Byte

szSystemStatus(0 To WSASYS_Status_Len) As Byte

iMaxSockets As Integer

iMaxUdpDg As Integer

lpszVendorInfo As Long

End Type

Private Declare Function gethostbyaddr Lib "WSOCK32.DLL" (addr As Any, ByVal _

byteslen As Integer, addrtype As Integer) As Long

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _

wVersionRequired&, lpWSAData As WSADATA) As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal _

hostname$) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, _

ByVal hpvSource&, ByVal cbCopy&)

Function hibyte(ByVal wParam As Integer) '获得整数的高位

hibyte = wParam \ &H100 And &HFF&

End Function

Function lobyte(ByVal wParam As Integer) '获得整数的低位

lobyte = wParam And &HFF&

End Function

Function SocketsInitialize()

Dim WSAD As WSADATA

Dim iReturn As Integer

Dim sLowByte As String, sHighByte As String, sMsg As String

iReturn = WSAStartup(WS_VERSION_REQD, WSAD)

If iReturn <> 0 Then

MsgBox "Winsock.dll 没有反应."

End

End If

If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then

sHighByte = Trim$(str$(hibyte(WSAD.wversion)))

sLowByte = Trim$(str$(lobyte(WSAD.wversion)))

sMsg = "Windows Sockets版本 " & sLowByte & "." & sHighByte

sMsg = sMsg & " 不被winsock.dll支持 "

MsgBox sMsg

End

End If

If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then

sMsg = "这个系统需要的最少Sockets数为 "

sMsg = sMsg & Trim$(str$(MIN_SOCKETS_REQD))

MsgBox sMsg

End

End If

End Function

Sub SocketsCleanup()

Dim lReturn As Long

lReturn = WSACleanup()

If lReturn <> 0 Then

MsgBox "Socket错误 " & Trim$(str$(lReturn)) & " occurred in Cleanup "

End

End If

End Sub

Sub Form_Load()

'初始化Socket

SocketsInitialize

End Sub

Private Sub Form_Unload(Cancel As Integer)

'清除Socket

SocketsCleanup

End Sub

Private Function getip(name As String) As String

Dim hostent_addr As Long

Dim host As HOSTENT

Dim hostip_addr As Long

Dim temp_ip_address() As Byte

Dim i As Integer

Dim ip_address As String

hostent_addr = gethostbyname(name)

If hostent_addr = 0 Then

getip = "" '主机名不能被解释

Exit Function

End If

RtlMoveMemory host, hostent_addr, LenB(host)

RtlMoveMemory hostip_addr, host.hAddrList, 4

ReDim temp_ip_address(1 To host.hLength)

RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength

For i = 1 To host.hLength

ip_address = ip_address & temp_ip_address(i) & "."

Next

ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)

getip = ip_address

End Function

Private Sub Command1_Click()

Dim str As String

str = getip(Text1.Text)

If str = "" Then

Text2.Text = "主机名不能被解释"

Else

Text2.Text = str

End If

End Sub

Private Function getname(addrstr As String) As String

Dim hostent_addr As Long

Dim host As HOSTENT

Dim addr(0 To 50) As Byte

Dim addrs As String

Dim hname(1 To 50) As Byte

Dim str As String

Dim i As Integer, j As Integer

Dim temp_int As Integer

Dim byt As Byte

str = Trim$(addrstr)

i = 0

j = 0

Do

temp_int = 0

i = i + 1

Do While Mid$(str, i, 1) >= "0" And Mid$(str, i, 1) <= "9" And i <= Len(str)

temp_int = temp_int * 10 + Mid$(str, i, 1)

i = i + 1

Loop

If temp_int <= 255 Then

addr(j) = temp_int

j = j + 1

End If

Loop Until Mid$(str, i, 1) <> "." Or i > Len(str) Or temp_int > 255

If temp_int > 255 Then

getname = "地址非法"

Exit Function

End If

hostent_addr = gethostbyaddr(addr(0), j, 2)

If hostent_addr = 0 Then

getname = "此地址无法解析"

Exit Function

End If

RtlMoveMemory host, hostent_addr, LenB(host)

RtlMoveMemory hname(1), host.hname, 50

j = 51

For i = 1 To 50

If hname(i) = 0 Then

j = i

End If

If i >= j Then

hname(i) = 32

End If

Next i

getname = Trim$(StrConv(hname, vbUnicode))

End Function

Private Sub Command2_Click()

Dim name As String

name = getname(Text2.Text)

If name = "" Then

name = "此地址没有域名"

End If

Text1.Text = name

End Sub

问题三: 怎么把图片加入到数据库里面

办法如下:

Private Sub Command3_Click()

Dim conn As New ADODB.Connection

conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\1.mdb;Persist Security Info=False"

conn.Execute "create table a (b longbinary)"

End Sub

Private Sub Command4_Click()

Set b = New ADODB.Recordset

Set c = New ADODB.Stream

c.Mode = adModeReadWrite

c.Type = adTypeBinary

c.Open

c.LoadFromFile "c:\1.bmp"

b.Open "select * from a", "Provider=Microsoft.Jet.OLEDB.4.0;"

Data Source=C:\1.mdb;Persist Security Info=False", adOpenDynamic, adLockOptimistic

b.AddNew

b.Fields.Item(0).Value = c.Read()

b.Update

b.Close

Set b = New ADODB.Recordset

b.Open "select * from a", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\1.mdb;Persist Security Info=False", adOpenKeyset, adLockOptimistic

MsgBox b.RecordCount

b.MoveLast

c.Write (b.Fields.Item(0).Value)

c.SaveToFile "c:\aa.bmp", adSaveCreateOverWrite

Picture1.Picture = LoadPicture("c:\aa.bmp")

End Sub

问题四：VB6.0中如何快速实现大面积不规则区域的填充

办法如下:

一?引言

区域填充是指先将区域内的一个像素 ，一般称为种子点赋予给定的颜色和辉亮，然后将该颜色扩展到整个区域内的过程。

二?已有的填充算法及缺点

1．扫描线法

扫描线法可以实现已知多边形域边界的填充，多边形域可以是凹的、凸的、还可以是带孔的。该填充方法是按扫描线的顺序，计算扫描线与待填充区域的相交区间，再用要求的颜色显示这些区间的像素，即完成填充工作。这里区间的端点通过计算扫描线与多边形边界线的交点获得。所以待填充区域的边界线必须事先知道，因此它的缺点是无法实现对未知边界的区域填充。

2．边填充算法

边填充的基本思想是：对于每一条扫描线和每条多边形边的交点，将该扫描线上交点右方的所有像素取补。对多边形的每条边作些处理，多边形的顺序随意。该算法适用于具有帧缓冲器的图形系统，按任意顺序处理多边形的边。处理每条边时，仅访问与该边有交的扫描线上交点右方的像素。所有的边都被处理之后，按扫描线顺序读出帧缓冲器的内容，送入显示设备。该算法的优点是简单，缺点是对于复杂图形，每一像素可能被访问多次，重要的是必须事先知道待填充多边形的边界，所以在填充未知边界的区域时不适用。

3．递归算法

递归算法的优点是编程实现时，语言简洁。但在VB6.0实际编程实现时，这种递归算法填充稍稍大一些的图形就会出现堆栈溢出现象，据我们的实践证明，递归算法只能连续递归深度在2090次左右，也就是说，如果待填充的图形大于二千多个像素那么堆栈溢出。下面给出八连通填充方法的VB程序实现(四连通算法同理)。

Public Sub area(P, q As Integer)

If ((imagepixels(0, P, q) = red1) And (imagepixels(1, P, q) = green1) And (imagepixels(2, P, q) = blue1)) Then

imagepixels(0, P, q) = 0: imagepixels(2, P, q) = 0: imagepixels(1, P, q) = 0

Picture1.PSet (P, q), RGB(0, 0, 0)

Call area(P + 1, q): Call area(P, q + 1)

Call area(P - 1, q): Call area(P, q - 1)

Call area(P + 1, q + 1): Call area(P + 1, q - 1)

Call area(P - 1, q + 1): Call area(P - 1, q - 1)

Else: Exit Sub

End If

End Sub

三?算法的基本思想

本算法采用两个队列（FIFO）filled和unfilled来实现区域填充。设计步骤如下：

1． 找出该区域内部任意一点，作为填充种子。

2． 填充该点,并把该点存入队列filled。

3． 按逆时针，判断该点的上、右、下、左邻像素是否在filled队列内。如果在filled，说明该相邻点已填充，若不在filled队列内，则判断该相邻点在未填充队列unfilled，如果不在则将该相邻点存入unfilled。

4． 判断未填充队列是否为空，若不空，则从队列unfilled中取出头元素，转向第三步。若为空则表示已完成所有像素填充，结束程序。

四?程序实现及说明

本算法定义的队列突破了递归算法中受堆栈空间大小的限制的束缚，因为它直接占用内存空间，与堆栈大小无关。以下源程序在Window 2000环境下用VB6.0编程实现。

建立如图所示标准窗体并画上控件-2个CommandButton控件和一个PictureBox控件,调整大小,并设置控件的属性。

通用声明

Dim Xx As Integer, Yy As Integer

Dim Array1(9000, 2), Array2(9000, 2) As Integer

4.2 采集

Private Sub Command1_Click()

Picture1.MousePointer = 2

End Sub

4.3 选取种子

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Xx = x '选择并记录种子点的位置

Yy = y

End Sub

4.4 区域填充

Private Sub Command2_Click()

Dim i, j, k As Integer, BoundPoint1, BoundPoint2 As Integer

Dim Flag As Boolean, Pixel As Long

Dim Red, Green, Blue As Integer, Bound As Boolean

Flag = True '初始化

i = Xx: j = Yy: BoundPoint1 = 1

Array1(1, 1) = i

Array1(1, 2) = j

'搜索边界点

Do While BoundPoint1 > 0

BoundPoint2 = 0

For k = 1 To BoundPoint1

i = Array1(k, 1)

j = Array1(k, 2)

'搜索右点

Pixel& = Picture1.Point(i, j + 1)

Call IsBound(Pixel&, Bound)

If Not Bound Then

BoundPoint2 = BoundPoint2 + 1

Array2(BoundPoint2, 1) = i

Array2(BoundPoint2, 2) = j + 1

Picture1.PSet (i, j + 1), RGB(255, 255, 255)

End If

'搜索左邻点

Pixel& = Picture1.Point(i, j - 1)

Call IsBound(Pixel&, Bound)

If Not Bound Then

BoundPoint2 = BoundPoint2 + 1

Array2(BoundPoint2, 1) = i

Array2(BoundPoint2, 2) = j - 1

Picture1.PSet (i, j - 1), RGB(255, 255, 255)

End If

'搜索上邻点

Pixel& = Picture1.Point(i - 1, j)

Call IsBound(Pixel&, Bound)

If Not Bound Then

BoundPoint2 = BoundPoint2 + 1

Array2(BoundPoint2, 1) = i - 1

Array2(BoundPoint2, 2) = j

Picture1.PSet (i - 1, j), RGB(255, 255, 255)

End If

'搜索下邻点

Pixel& = Picture1.Point(i + 1, j)

Call IsBound(Pixel&, Bound)

If Not Bound Then

BoundPoint2 = BoundPoint2 + 1

Array2(BoundPoint2, 1) = i + 1

Array2(BoundPoint2, 2) = j

Picture1.PSet (i + 1, j), RGB(255, 255, 255)

End If

Next k

'数组array2 中的数据传给array1

BoundPoint1 = BoundPoint2

For k = 1 To BoundPoint1

Array1(k, 1) = Array2(k, 1)

Array1(k, 2) = Array2(k, 2)

Next k

Picture1.Refresh

Loop

End Sub

Public Sub IsBound(P As Long, Bound As Boolean) '判断P是否为边界点

Red = P& Mod 256

Bound = False

Green = ((P& And &HFF00) / 256&) Mod 256&

Blue = (P& And &HFF0000) / 65536

If Red = 255 And Green = 255 And Blue = 255 Then

Bound = True

End If

End Sub

五?结束语

本算法实现了在对填充区域的形状、大小均未知的情况下，以种子点开始向四周对该区域进行“扩散式”的填充。本算法解决了传统的递归算法在填充较大区域时（本例中填充区约9800Pixels）堆栈溢出的缺点。我们的实验结果显示，本算法就填充区域大小和运算速度而言，都远远超过了传统的递归算法。

问题五：如何获取打印机纸张信息？

办法如下:

Option Explicit

Private Const DC_MAXEXTENT = 5

Private Const DC_MINEXTENT = 4

Private Const DC_PAPERNAMES = 16

Private Const DC_PAPERS = 2

Private Const DC_PAPERSIZE = 3

Private Declare Function DeviceCapabilities Lib "winspool.drv" ()

Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String,

ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, lpDevMode As Any) As Long

Private Type POINTS

x As Long

y As Long

End Type

'***********************************************************

'* 名称：GetPaperInfo

'* 功能：得到打印机低张信息

'* 用法：GetPaperInfo(控件名)

'* 描述：如在 form_load()中调用GetPaperInfo MSHFlexGrid1

'***********************************************************

Public Function GetPaperInfo(Flex As MSHFlexGrid) As Boolean

Dim i As Long, ret As Long

Dim Length As Integer, Width As Integer

Dim PaperNo() As Integer, PaperName() As String, PaperSize() As POINTS

With Flex

.FormatString = "^纸张编号|^纸张名称|^纸张长度|^纸张宽度"

For i = 0 To .Cols - 1

.ColWidth(i) = 1700

Next i

.AllowUserResizing = flexResizeColumns

.Left = 0

End With

'支持最大打印纸：

ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_MAXEXTENT, ByVal 0&, ByVal 0&)

Length = ret \ 65536

Width = ret - Length * 65536

'支持最小打印纸：

ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_MINEXTENT, ByVal 0&, ByVal 0&)

Length = ret \ 65536

Width = ret - Length * 65536

'支持纸张种类数

ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, ByVal 0&, ByVal 0&)

'纸张编号

ReDim PaperNo(1 To ret) As Integer

Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, PaperNo(1), ByVal 0&)

'纸张名称

Dim arrPageName() As Byte

Dim allNames As String

Dim lStart As Long, lEnd As Long

ReDim PaperName(1 To ret) As String

ReDim arrPageName(1 To ret * 64) As Byte

Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERNAMES, arrPageName(1), ByVal 0&)

allNames = StrConv(arrPageName, vbUnicode)

'loop through the string and search for the names of the papers

i = 1

Do

lEnd = InStr(lStart + 1, allNames, Chr$(0), vbBinaryCompare)

If (lEnd > 0) And (lEnd - lStart - 1 > 0) Then

PaperName(i) = Mid$(allNames, lStart + 1, lEnd - lStart - 1)

i = i + 1

End If

lStart = lEnd

Loop Until lEnd = 0

'纸张尺寸

ReDim PaperSize(1 To ret) As POINTS

Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERSIZE, PaperSize(1), ByVal 0&)

'显示在表格中

For i = 1 To ret

Flex.AddItem PaperNo(i) & vbTab & PaperName(i)

& vbTab & PaperSize(i).y & vbTab & PaperSize(i).x

Next i

End Function

问题六: 在DataGrid中显示DataCombo

办法如下:

DataGrid1_MouseDown

Dim col As MSDataGridLib.Column

Set col = DataGrid1.Columns(DataGrid1.col)

If col.Caption = "MS" And DataGrid1.CurrentCellVisible Then

DataCombo1.Left = DataGrid1.Left + col.Left + 2 * Screen.TwipsPerPixelX

DataCombo1.Top = DataGrid1.Top + DataGrid1.RowTop(DataGrid1.Row) + 2 * Screen.TwipsPerPixelX

DataCombo1.Width = col.Width - 2 * Screen.TwipsPerPixelX

DataCombo1.Text = col.Text

DataCombo1.Visible = True

DataCombo1.SetFocus

DataCombo1.ZOrder

Else

DataCombo1.Visible = False

End If

问题七：如何识别操作系统版本？

办法如下:

'引用控件 Microsoft SysInfo Control 6.0

Dim OS As String

With SysInfo1

   Select Case .OSPlatform

Case 0: OS = "Win32"

Case 1:

  Select Case .OSVersion

Case 4: OS = "Win 95"

Case 4.1: OS = "Win 98"

Case 4.9: OS = "Wim Me"

   End Select

Case 2:

  Select Case .OSVersion

    Case 4: OS = "Win NT"

    Case 5: OS = "Win 2000"

    Case 6: OS = "Win XP"

  End Select

   End Select

   MsgBox "Build:" & .OSBuild & vbNewLine & _

"Platform:" & OS & "(" & .OSPlatform & ")" & vbNewLine & _

"Version:" & .OSVersion

End With

问题八: 如何实现遍历文件夹中的所有文件

办法如下:

把下面放到模块中

Option Explicit

Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _

(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _

(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Public Const MAX_PATH = 260

Public Const FILE_ATTRIBUTE_ARCHIVE = &H20

Public Const FILE_ATTRIBUTE_COMPRESSED = &H800

Public Const FILE_ATTRIBUTE_DIRECTORY = &H10

Public Const FILE_ATTRIBUTE_HIDDEN = &H2

Public Const FILE_ATTRIBUTE_NORMAL = &H80

Public Const FILE_ATTRIBUTE_READONLY = &H1

Public Const FILE_ATTRIBUTE_SYSTEM = &H4

Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

'自定义数据类型FILETIME和WIN32_FIND_DATA的定义

Public Type FILETIME

   dwLowDateTime As Long

   dwHighDateTime As Long

End Type

Public Type WIN32_FIND_DATA

   dwFileAttributes As Long

   ftCreationTime As FILETIME

   ftLastAccessTime As FILETIME

   ftLastWriteTime As FILETIME

   nFileSizeHigh As Long

   nFileSizeLow As Long

   dwReserved0 As Long

   dwReserved1 As Long

   cFileName As String * MAX_PATH

   cAlternate As String * 14

End Type

----------------------

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

' 把当前文件夹路径下的所有文件入到listview中

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

Private Sub finfiles(tCurrentdir As String)

   Dim itmX As ListItem

   Dim tFindData As WIN32_FIND_DATA

   Dim strFileName As String

   Dim lHandle As Long

   Dim CountFolder As Integer

   Dim CountFiles As Integer

   CountFolder = 0

   CountFiles = 0

   ListView1.ListItems.Clear

   lHandle = FindFirstFile(tCurrentdir & "\*.*", tFindData)

   If lHandle = 0 Then

Set itmX = ListView1.ListItems.Add(, , strFileName & "找不到文件")

Exit Sub

   End If

   strFileName = fDelInvaildChr(tFindData.cFileName)

   Do While True

tFindData.cFileName = ""

If FindNextFile(lHandle, tFindData) = 0 Then

  FindClose (lHandle)

  Exit Do

Else

  strFileName = fDelInvaildChr(tFindData.cFileName)

  If tFindData.dwFileAttributes = &H10 Then

    If strFileName <> "." And strFileName <> "." Then

 Set itmX = ListView1.ListItems.Add(, , strFileName)

 itmX.SmallIcon = 1

 CountFolder = CountFolder + 1

    End If

  Else

    Debug.Print InStr(LCase(Right(strFileName, 3)), ExtendFileName)

    If InStr(ExtendFileName, LCase(Right(strFileName, 3))) > 0 Then

 Set itmX = ListView1.ListItems.Add(, , strFileName)

 itmX.SubItems(1) = CStr(FileLen(tCurrentdir & "\" & strFileName))

 itmX.SmallIcon = 2

 itmX.SubItems(2) = FileDateTime(tCurrentdir & "\" & strFileName)

 CountFiles = CountFiles + 1

    End If

  End If

End If

   Loop

   ListView1.Sorted = True

   ListView1.SortKey = 1

   StatusBar1.Panels(2).Text = CurrentDir

   StatusBar1.Panels(3).Text = "文件夹：" & CountFolder & " 文件：" & CountFiles

End Sub

问题九:  如何让你的程序在任务列表隐藏

办法如下:

Private Declare Function RegisterServiceProcess Lib "kernel32" ()

(ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long

Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long

  '请你试试 Ctrl+Alt+Del 是不是你的程序隐藏了

Private Sub Command1_Click()

   i = RegisterServiceProcess(GetCurrentProcessId, 1)

End Sub

问题十:如何计算出本月的最后一天

办法如下:

首先为下个月的第一天生成一个顺序数值，然后再减去一天

Private Sub Command1_Click()

   Dim dtl As Date

   dtl = DateSerial(Year(Now), Month(Now) + 1, 1) - 1

   MsgBox dtl

End Sub

-------------------------------------------------------------------------------------------

错误的作法 ==> x = Shell("c:\windows\Sheep.scr") '这种作法只能开启屏幕保护程序的设定画面而已！

正确的作法 ==> Shell ("start c:\windows\sheep.scr") '这种作法才能正确启动屏幕保护程序

------------------------------------------------------------------------------------

Sub mnuEditText_Click(Index As Integer)

   ' 我们只要使用 SendKeys，其他的就让 Windows 去做吧！

   Select Case Index

Case 0 '复原/UNDO

  SendKeys "^Z" 'Keys Ctrl+Z

Case 1 '剪下/CUT

  SendKeys "^X" 'Keys Ctrl+X

Case 2 '复制/COPY

  SendKeys "^C" 'Keys Ctrl+C

Case 3 '贴上/PASTE

  SendKeys "^V" 'Keys Ctrl+V

   End Select

End Sub

-------------------------------------------------------------------------------------

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

'加入以下程序码：

Private Sub Command1_Click()

   MsgBox "计时器停掉了！", 64, "VB 的讯息框"

End Sub

Private Sub Command2_Click()

   Timer1.Enabled = 1

   MessageBox Me.hwnd, "注意！计时器还在跑！", "API 的讯息框", 64

End Sub

Private Sub Form_Load()

   Timer1.Interval = 2000

   Label1.Caption = "目前的时间是：" & time

End Sub

Private Sub Timer1_Timer()

   SendKeys Chr(13)

   Timer1.Enabled = 0

End Sub