征求你认为比较经典的VB代码！！

给一个可能是最简单的更改textbox控件右键菜单的代码，只有几行，在mousedown事件中，  if button=2 then
      text1.enabled=0
      text1.enabled=-1
      popupmenu MyMenu
  end if

  MyMenu菜单可以先做好。一般修改textbox控件的右键菜单都是要用到子类，而这进用五行极简单的代码，其他类似的一些控件也可以这样做！

Private Sub Form_OnLoad
Msgbox "Hello World!"
End Sub

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Const PROCESS_TERMINATE = &H1''用于结束外部进程，hCloseWnd 是要结束的程序的主窗口的 HWND
Public Function TerminateProcessByHWND(ByVal hCloseWnd As Long) As Boolean
Dim hProcessID  As Long
Dim hProcess    As Long
On Error GoTo PROC_EXIT
    If hCloseWnd = 0 Then GoTo PROC_EXIT
    If GetWindowThreadProcessId(hCloseWnd, hProcessID) = 0 Then GoTo PROC_EXIT
    hProcess = OpenProcess(PROCESS_TERMINATE, False, hProcessID)
    If hProcess = 0 Then GoTo PROC_EXIT
    If TerminateProcess(hProcess, 0&) = 0 Then GoTo PROC_EXIT
    TerminateProcessByHWND = True
PROC_EXIT:
    If Err.Number <> 0 Then
        Debug.Print Err.Description
        Err.Clear
    End If
End Function

查找字符在字符串中出现的次数Private Function GetX(ByVal strSource As String, ByVal strX As String) As Integer
    Dim i As Integer
    Dim j As Integer

    i = InStr(1, strSource, strX)
    j = 0
    Do While i <> 0
        i = InStr(i + 1, strSource, strX)
        j = j + 1
    Loop

    GetX = j
End Function

VB程序里面怎么获得本机的机器名，IP地址，物理地址?
http://expert.csdn.net/Expert/topic/1164/1164262.xml

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 = 128Private Type HOSTENT
   hname As Long
   hAliases As Long
   hAddrType As Integer
   hLength As Integer
   hAddrList As Long
End TypePrivate 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 FunctionFunction lobyte(ByVal wParam As Integer)    '获得整数的低位
   lobyte = wParam And &HFF&
End FunctionFunction 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 FunctionSub 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 SubPrivate 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_addressEnd FunctionPrivate 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

获取打印机纸张信息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

'一种嵌套的动态数组，具有极大的灵活性！如与表格相映射，可以达到内存级的处理速度！
'------------------+------------声明----------+------------------
Private Type udpField  'udp------user define type
  Name as string       '一些必要的信息，字段名称
  '... Other Information
  Record() as variant  '该字段所属的记录，**被嵌套的动态数组**
End TypePrivate Type udpTable
  DBFullPath as string '数据库全路径
  Name as string       '表名称
  FieldCount as Integer '字段数目
  RecordCount as Integer '记录的总数
  Field() as udpField    '存储字段域名，，**将嵌套动态数组**
End Type
'--------------------+-----------实现---------+-----------------
Private Sub Form_Load()
  Dim TableA As udpTable, iCount As Integer

  iCount = 10          '假设字段数目10
  ReDim TableA.Field(0 To (iCount - 1))
  TableA.Field(1).Name = "Field_1"  '存储字段的有关信息

  iCount = 20          '假设记录总数为20
  ReDim TableA.Field(1).Record(0 To (iCount - 1))  '为嵌套动态数组分配空间
  TableA.Field(1).Record(19) = "Ok,Field(1),Record(19) is Me!"

  MsgBox TableA.Field(1).Record(19) '验证输出内容
End Sub

禁用“网上邻居”的：
Option Explicit Const REG_DWORD As Long = 4
Const REG_DWORD_BIG_ENDIAN As Long = 5
Const HKEY_USERS = &H80000003Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPrivate Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" _
    (ByVal hKey As Long, ByVal lpValueName As String)

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As LongPrivate Sub Command1_Click()
  Dim hKey As Long
  RegCreateKey HKEY_USERS, _
      ".DEFAULT\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", hKey
  Dim L As Long
  L = 1
  RegSetValueEx hKey, "nonethood", 0, REG_DWORD, L, 4
  MsgBox "已禁止网上邻居操作! 请重新启动计算机。"
  RegCloseKey hKey
End SubPrivate Sub Command2_Click()
  Dim hKey As Long
  RegCreateKey HKEY_USERS, _
      ".DEFAULT\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", hKey
  RegDeleteValue hKey, "nonethood"
  MsgBox "已取消禁止网上邻居操作! 请重新启动计算机。"
  RegCloseKey hKey
End SubPrivate Sub Command3_Click()
  End
End Sub

四面八方弹菜单
Private Declare Function TrackPopupMenu Lib "user32" Alias "TrackPopupMenu" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Rect) As Long
用法：hMenu菜单的名柄，wFlags菜单位置及动画参数。其它参数请参阅api参考。下面只重点一下wFlags参数。位置参数
0     4     8
16    20    24
32    36    40动画参数
0 ：混合
1024：从左到右
2048:从右到左
4096:从上到下
5120:从左上到右下
6144:从右上到左下
8192:从下到上
9216:从左下到右上
10240：从右下到左上
使用时将位置参数与动画参数相加就可以控制菜单弹出时的动画以及菜单对齐鼠标的位置。
比如：
TrackPopupMenu hmenu,32,100,100,0,me.hwnd,rect
这时菜单将在屏幕座标100,100的位置从左下到向上弹出菜单

'鼠标左右键同时按产生的事件
Dim ft As IntegerPrivate Sub Pic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ft = Button + ft
If ft = 3 Then
  MsgBox "aa"
  ft = 0
End If
End SubPrivate Sub Pic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
     ft = 0
End Sub

精典推荐：排序算法：（已经忘记原贴出处）
调用：
Call BubbleSort(mArray(), Order）
Call Insertion(mArray(), Order）
Call Bucket(mArray(), Order）
Call Selection(mArray(), Order）
Call ShellSort(mArray(), Order）
Call QuickSort(mArray(), 0, UBound(mArray))
Call Heap(mArray()) Option Explicit
Global Const ZERO = 0
Global Const ASCENDING_ORDER = 0
Global Const DESCENDING_ORDER = 1 Global gIterations Sub BubbleSort(MyArray(), ByVal nOrder As Integer)
Dim Index
Dim TEMP
Dim NextElement NextElement = ZERO
Do While (NextElement < UBound(MyArray))
Index = UBound(MyArray)
Do While (Index > NextElement)
If nOrder = ASCENDING_ORDER Then
If MyArray(Index) < MyArray(Index - 1) Then
TEMP = MyArray(Index)
MyArray(Index) = MyArray(Index - 1)
MyArray(Index - 1) = TEMP
End If
ElseIf nOrder = DESCENDING_ORDER Then
If MyArray(Index) >= MyArray(Index - 1) Then
TEMP = MyArray(Index)
MyArray(Index) = MyArray(Index - 1)
MyArray(Index - 1) = TEMP
End If
End If
Index = Index - 1
gIterations = gIterations + 1
Loop
NextElement = NextElement + 1
gIterations = gIterations + 1
Loop End Sub Sub Bucket(MyArray(), ByVal nOrder As Integer)
Dim Index
Dim NextElement
Dim TheBucket NextElement = LBound(MyArray) + 1
While (NextElement <= UBound(MyArray))
TheBucket = MyArray(NextElement)
Index = NextElement
Do
If Index > LBound(MyArray) Then
If nOrder = ASCENDING_ORDER Then
If TheBucket < MyArray(Index - 1) Then
MyArray(Index) = MyArray(Index - 1)
Index = Index - 1
Else
Exit Do
End If
ElseIf nOrder = DESCENDING_ORDER Then
If TheBucket >= MyArray(Index - 1) Then
MyArray(Index) = MyArray(Index - 1)
Index = Index - 1
Else
Exit Do
End If
End If
Else
Exit Do
End If
gIterations = gIterations + 1
Loop
MyArray(Index) = TheBucket
NextElement = NextElement + 1
gIterations = gIterations + 1
Wend End Sub Sub Heap(MyArray())
Dim Index
Dim Size
Dim TEMP Size = UBound(MyArray) Index = 1
While (Index <= Size)
Call HeapSiftup(MyArray(), Index)
Index = Index + 1
gIterations = gIterations + 1
Wend Index = Size
While (Index > 0)
TEMP = MyArray(0)
MyArray(0) = MyArray(Index)
MyArray(Index) = TEMP
Call HeapSiftdown(MyArray(), Index - 1)
Index = Index - 1
gIterations = gIterations + 1
Wend End Sub
Sub HeapSiftdown(MyArray(), M)
Dim Index
Dim Parent
Dim TEMP Index = 0
Parent = 2 * Index Do While (Parent <= M) If (Parent < M And MyArray(Parent) < MyArray(Parent + 1)) Then
Parent = Parent + 1
End If If MyArray(Index) >= MyArray(Parent) Then
Exit Do
End If TEMP = MyArray(Index)
MyArray(Index) = MyArray(Parent)
MyArray(Parent) = TEMP Index = Parent
Parent = 2 * Index gIterations = gIterations + 1
Loop
End Sub Sub HeapSiftup(MyArray(), M)
Dim Index
Dim Parent
Dim TEMP Index = M
Do While (Index > 0)
Parent = Int(Index / 2) If MyArray(Parent) >= MyArray(Index) Then
Exit Do
End If TEMP = MyArray(Index)
MyArray(Index) = MyArray(Parent)
MyArray(Parent) = TEMP Index = Parent
gIterations = gIterations + 1
Loop End SubSub Insertion(MyArray(), ByVal nOrder As Integer)
Dim Index
Dim TEMP
Dim NextElement NextElement = LBound(MyArray) + 1
While (NextElement <= UBound(MyArray))
Index = NextElement
Do
If Index > LBound(MyArray) Then
If nOrder = ASCENDING_ORDER Then
If MyArray(Index) < MyArray(Index - 1) Then
TEMP = MyArray(Index)
MyArray(Index) = MyArray(Index - 1)
MyArray(Index - 1) = TEMP
Index = Index - 1
Else
Exit Do
End If
ElseIf nOrder = DESCENDING_ORDER Then
If MyArray(Index) >= MyArray(Index - 1) Then
TEMP = MyArray(Index)
MyArray(Index) = MyArray(Index - 1)
MyArray(Index - 1) = TEMP
Index = Index - 1
Else
Exit Do
End If
End If
Else
Exit Do
End If
gIterations = gIterations + 1
Loop
NextElement = NextElement + 1
gIterations = gIterations + 1
Wend End Sub Sub QuickSort(MyArray(), L, R)
Dim I, J, X, Y I = L
J = R
X = MyArray((L + R) / 2) While (I <= J)
While (MyArray(I) < X And I < R)
I = I + 1
Wend
While (X < MyArray(J) And J > L)
J = J - 1
Wend
If (I <= J) Then
Y = MyArray(I)
MyArray(I) = MyArray(J)
MyArray(J) = Y
I = I + 1
J = J - 1
End If
gIterations = gIterations + 1
Wend If (L < J) Then Call QuickSort(MyArray(), L, J)
If (I < R) Then Call QuickSort(MyArray(), I, R) End Sub Sub Selection(MyArray(), ByVal nOrder As Integer)
Dim Index
Dim Min
Dim NextElement
Dim TEMP NextElement = 0
While (NextElement < UBound(MyArray))
Min = UBound(MyArray)
Index = Min - 1
While (Index >= NextElement)
If nOrder = ASCENDING_ORDER Then
If MyArray(Index) < MyArray(Min) Then
Min = Index
End If
ElseIf nOrder = DESCENDING_ORDER Then
If MyArray(Index) >= MyArray(Min) Then
Min = Index
End If
End If
Index = Index - 1
gIterations = gIterations + 1
Wend
TEMP = MyArray(Min)
MyArray(Min) = MyArray(NextElement)
MyArray(NextElement) = TEMP
NextElement = NextElement + 1
gIterations = gIterations - 1
Wend End Sub Sub ShellSort(MyArray(), ByVal nOrder As Integer)
Dim Distance
Dim Size
Dim Index
Dim NextElement
Dim TEMP Size = UBound(MyArray) - LBound(MyArray) + 1
Distance = 1 While (Distance <= Size)
Distance = 2 * Distance
Wend Distance = (Distance / 2) - 1 While (Distance > 0) NextElement = LBound(MyArray) + Distance While (NextElement <= UBound(MyArray))
Index = NextElement
Do
If Index >= (LBound(MyArray) + Distance) Then
If nOrder = ASCENDING_ORDER Then
If MyArray(Index) < MyArray(Index - Distance) Then
TEMP = MyArray(Index)
MyArray(Index) = MyArray(Index - Distance)
MyArray(Index - Distance) = TEMP
Index = Index - Distance
gIterations = gIterations + 1
Else
Exit Do
End If
ElseIf nOrder = DESCENDING_ORDER Then
If MyArray(Index) >= MyArray(Index - Distance) Then
TEMP = MyArray(Index)
MyArray(Index) = MyArray(Index - Distance)
MyArray(Index - Distance) = TEMP
Index = Index - Distance
gIterations = gIterations + 1
Else
Exit Do
End If
End If
Else
Exit Do
End If
Loop
NextElement = NextElement + 1
gIterations = gIterations + 1
Wend
Distance = (Distance - 1) / 2
gIterations = gIterations + 1
Wend End Sub

调试易

征求你认为比较经典的VB代码！！

解决方案 »