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