-
怎样求汉字的字符串长度？
Private Sub Form_Load()
Text1 = LenB(StrConv("大ds的都34", vbFromUnicode))
End Sub
得到10
-
提取 CPU 序列号
Option Explicit
Private Declare Function GetCPU Lib "GetCPU.dll" ( _
ByVal sVendor As String, _
ByVal sFamily As String, _
ByVal sModel As String, _
ByVal sStepping As String, _
ByVal sType As String, _
ByVal sBrandString As String, _
ByVal sBrandIDString As String, _
ByVal sProcessorNameString As String, _
ByVal sSpeed As String, _
ByVal sCacheString As String, _
ByVal sSerialNr As String, _
ByVal sCPU As String _
) As Long
Private Declare Function GetFeatures Lib "GetCPU.dll" ( _
ByVal sFeatures As String) As Long
Private Sub Command1_Click()
Me.Cls
Me.MousePointer = vbHourglass
Dim sVendor As String
Dim sFamily As String
Dim sModel As String
Dim sStepping As String
Dim sType As String
Dim sBrandString As String
Dim sBrandIDString As String
Dim sProcessorNameString As String
Dim sSpeed As String
Dim sCacheString As String
Dim sSerialNr As String
Dim sCPU As String
sVendor = Space$(255)
sFamily = Space$(255)
sModel = Space$(255)
sStepping = Space$(255)
sType = Space$(255)
sBrandString = Space$(255)
sBrandIDString = Space$(255)
sProcessorNameString = Space$(255)
sSpeed = Space$(255)
sCacheString = Space$(2048)
sSerialNr = Space$(255)
sCPU = Space$(255)
GetCPU sVendor, sFamily, sModel, sStepping, sType, _
sBrandString, sBrandIDString, sProcessorNameString, _
sSpeed, sCacheString, sSerialNr, sCPU
Me.Print "CPU: " & Left$(sCPU, Len(Trim$(sCPU)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Vendor: " & Left$(sVendor, Len(Trim$(sVendor)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Brand: " & Left$(sBrandString, Len(Trim$(sBrandString)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Brand ID: " & Left$(sBrandIDString, Len(Trim$(sBrandIDString)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "ProcessorName: " & Left$(sProcessorNameString, Len(Trim$(sProcessorNameString)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Family: " & Left$(sFamily, Len(Trim$(sFamily)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Model: " & Left$(sModel, Len(Trim$(sModel)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Stepping: " & Left$(sStepping, Len(Trim$(sStepping)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Type: " & Left$(sType, Len(Trim$(sType)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Speed: " & Left$(sSpeed, Len(Trim$(sSpeed)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Cache: " & Left$(sCacheString, Len(Trim$(sCacheString)) - 1)
Me.Print "------------------------------------------------------------"
Me.Print "Serial Nr: " & Left$(sSerialNr, Len(Trim$(sSerialNr)) - 1)
Me.Print "------------------------------------------------------------"
Me.MousePointer = vbDefault
End Sub
Private Sub Command2_Click()
Dim sFeatures As String
sFeatures = Space$(1500)
Me.Cls
GetFeatures sFeatures
Me.Print Left$(sFeatures, Len(Trim$(sFeatures)) - 1)
End Sub
GetCpu.dll 下载地址
http://www2.arnes.si/~sodbobla/
-
程序读取test.txt的第1行，第三行，第20行
新建一个工程，在同一目录下建立test.txt文件。下面的程序读取test.txt的第1行，第三行，第20行，并分别显示到窗体的text1,text2,text3中。
当然这是个笨办法，至于其中有什么缺陷还没有发现，请斑竹一并指点。
Private Sub Form_Load()
Open App.Path & "\" & "test.txt" For Input As #1
For i = 1 To 20
If i = 1 Then
Line Input #1, a
Text1.Text = a
ElseIf i = 2 Then
Line Input #1, blank
ElseIf i = 3 Then
Line Input #1, b
Text2.Text = b
ElseIf i > 3 And i < 20 Then
Line Input #1, blank
ElseIf i = 20 Then
Line Input #1, c
Text3.Text = c
End If
Next i
Close #1
End Sub
-
如何限制文本框输入
刚刚看到的有人提如何限制文本框输入，给大家一个过程...
Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer
Dim ValidateList As String
Dim KeyOut As Integer
If Editable = True Then
ValidateList = UCase(ValidateString) & Chr(8)
Else
ValidateList = UCase(ValidateString)
End If
If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
KeyOut = KeyIn
Else
KeyOut = 0
Beep
End If
ValiText = KeyOut
End Function
用法是：
keycode=valitext(keycode,"0123456789",true)
试试看..
-
日期计算
"获取给定日期的当月第一天
Private Function getFirstDayOfMonth(ByVal D As Date) As Date
getFirstDayOfMonth = CDate(Year(D) & "-" & Month(D) & "-1")
End Function
"获取给定日期的当月最后一天
Private Function getLastDayOfMonth(ByVal D As Date) As Date
Dim dteFirstDayOfNextMonth As Date
dteFirstDayOfNextMonth = DateAdd("m", 1, getFirstDayOfMonth(D))
getLastDayOfMonth = DateAdd("d", -1, dteFirstDayOfNextMonth)
End Function
"获取给定日期的当年第一天
Private Function getFirstDayOfYear(ByVal D As Date) As Date
getFirstDayOfYear = CDate(Year(D) & "-1-1")
End Function
"获取给定日期的当年最后一天
Private Function getLastDayOfYear(ByVal D As Date) As Date
getLastDayOfYear = CDate(Year(D) & "-12-31")
End Function
-
远程（如通过互联网）连接access数据库的方法
前段时间很多人问远程（如通过互联网）连接access数据库的方法，最近写了个例子，与大家共享：
使用了TCP/IP，ADO及XML（需要安装Microsoft XML 4.0。）。分服务器和客户端两部分，服务器可以多用户同时连接。远程连接Access数据库有很多方法，我以前已经比较详细的回答过（见下面所列的5种方法），我现在这个例子属于其中的第３种方法（不需要使用RDS或Web服务器）。
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
远程连接access数据库的几个方法：
１．建立VPN(Virtual Private Network)，这样你的电脑和主机的连接就与局域网无异，然后把服务器中mdb文件所在的Folder共享即可。ADO连接如下：
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\\ServerName\DatabaseFolder\Database.mdb;Jet OLEDB:Database Password=databasepw;Persist Security Info=False"
２．把Database放在Web Server上，使ADO或RDO通过RDS（Remote Data Service）及IIS来实现：
如果服务器像上面Jave大侠说那样设置了ODBC DSN的话：
oConn.Open "Provider=MS Remote;" & _
"Remote Server=http://myServerName;" & _
"Remote Provider=MSDASQL;" & _
"DSN=AdvWorks;" & _
"Uid=myUsername;" & _
"Pwd=myPassword"
如果设置的是OLE DB Provider 的话：
oConn.Open "Provider=MS Remote;" & _
"Remote Server=http://myServerName;" & _
"Remote Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=c:\somepath\mydb.mdb", _
"admin", ""
３．自己编写服务器程序，通过TCP/IP，传递Recordset。
４．使用第三方控件，如：ADO Anywhere或UDAParts RDB等。具体查看
http://www.adoanywhere.com
http://www.udaparts.com/
５．使用XMLHTTP
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
附 远程连接SQL Server的方法：
ConnStr = "Provider=SQLOLEDB.1;Network Library=DBMSSOCN;Persist Security Info=True;User ID=UserName;Password=Password;Initial Catalog=远程数据库名;Data Source=203.129.92.1"
-
取得网卡序列号
取得网卡序列号
很多软件以取得网卡地址作为License验证，这不失为一个验证合法用户的好办法，不过要付出回复用户电话、传真的代价哦 ^_^
将下面这段代码拷贝到程序中，然后在你的程序需要的时候调用EthernetAddress(0),该函数返回的字符串就是您机器上网卡的以太序列号。
Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32
Private Type NCB
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve(9) As Byte ' Reserved, must be 0
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" _
(pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, _
ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () _
As Long
Private Declare Function HeapAlloc Lib "kernel32" _
(ByVal hHeap As Long, ByVal dwFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" _
(ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) _
As Long
Private Function EthernetAddress(LanaNumber As Long) _
As String
Dim udtNCB As NCB
Dim bytResponse As Byte
Dim udtASTAT As ASTAT
Dim udtTempASTAT As ASTAT
Dim lngASTAT As Long
Dim strOut As String
Dim x As Integer
udtNCB.ncb_command = NCBRESET
bytResponse = Netbios(udtNCB)
udtNCB.ncb_command = NCBASTAT
udtNCB.ncb_lana_num = LanaNumber
udtNCB.ncb_callname = "* "
udtNCB.ncb_length = Len(udtASTAT)
lngASTAT = HeapAlloc(GetProcessHeap(), _
HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
strOut = ""
If lngASTAT Then
udtNCB.ncb_buffer = lngASTAT
bytResponse = Netbios(udtNCB)
CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
With udtASTAT.adapt
For x = 0 To 5
strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
Next x
End With
HeapFree GetProcessHeap(), 0, lngASTAT
End If
EthernetAddress = strOut
End Function
Private Sub Form_Load()
MsgBox EthernetAddress(0)
End Sub