VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 7444|回复: 21

[转帖] 送给朋友的新年礼物——我的VB收藏归纳

[复制链接]
 楼主| 发表于 2009-1-11 20:16:57 | 显示全部楼层 |阅读模式

  1. 一个键盘HOOK完整的例子
  2. --------------------------------------------------------------------------------
  3. 作者:不详  来源于:中国VB网  发布时间:2007-3-7
  4. modHook.bas-------------------------------------------------

  5. Option Explicit

  6. Public Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As Long
  7. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
  8. Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)


  9. Public Datas() As String
  10. Public NUM As Long
  11. Public OldHook As Long
  12. Public LngClsPtr As Long

  13. Public Function BackHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
  14. If nCode < 0 Then
  15. BackHook = CallNextHookEx(OldHook, nCode, wParam, lparam)
  16. Exit Function
  17. End If

  18. ResolvePointer(LngClsPtr).RiseEvent (lparam)
  19. Call CallNextHookEx(OldHook, nCode, wParam, lparam)
  20. End Function

  21. Private Function ResolvePointer(ByVal lpObj As Long) As ClsHook

  22. Dim oSH As ClsHook
  23. CopyMemory oSH, lpObj, 4&

  24. Set ResolvePointer = oSH
  25. CopyMemory oSH, 0&, 4&
  26. End Function

  27. ClsHook.cls---------------------------------------------------

  28. Option Explicit

  29. Public Event KeyDown(KeyCode As Integer, Shift As Integer)

  30. Private Type EVENTMSG
  31. wMsg As Long
  32. lParamLow As Long
  33. lParamHigh As Long
  34. msgTime As Long
  35. hWndMsg As Long
  36. End Type

  37. Private Const WH_JOURNALRECORD = 0

  38. Private Const WM_KEYDOWN = &H100

  39. Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
  40. Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
  41. Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer

  42. Public Sub SetHook()
  43. OldHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf BackHook, App.hInstance, 0)
  44. End Sub

  45. Public Sub UnHook()
  46. Call UnhookWindowsHookEx(OldHook)
  47. End Sub

  48. Friend Function RiseEvent(ByVal lparam As Long) As Long
  49. Dim Msg As EVENTMSG
  50. Dim IntShift As Integer
  51. Dim IntCode As Integer

  52. CopyMemory Msg, ByVal lparam, Len(Msg)

  53. IntShift = 0
  54. Select Case Msg.wMsg
  55. Case WM_KEYDOWN
  56. If GetAsyncKeyState(vbKeyShift) Then IntShift = (IntShift Or 1)
  57. If GetAsyncKeyState(vbKeyControl) Then IntShift = (IntShift Or 2)
  58. If GetAsyncKeyState(vbKeyMenu) Then IntShift = (IntShift Or 4)

  59. IntCode = Msg.lParamLow And &HFF
  60. Debug.Print Msg.lParamLow
  61. Debug.Print &HFF
  62. RaiseEvent KeyDown(IntCode, IntShift)
  63. End Select
  64. End Function

  65. Private Sub Class_Initialize()
  66. LngClsPtr = ObjPtr(Me)
  67. End Sub

  68. form1.frm------------------------------------------------------------

  69. Option Explicit
  70. Dim WithEvents Hook As ClsHook
  71. Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long
  72. Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
  73. Private Declare Function GetForegroundWindow Lib "user32" () As Long
  74. Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

  75. Private Sub Hook_KeyDown(KeyCode As Integer, Shift As Integer)
  76. Dim StrCode As String

  77. StrCode = CodeToString(KeyCode)

  78. If StrCode = "[Shift]" Or StrCode = "[Alt]" Or StrCode = "[Ctrl]" Then
  79. If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl]"
  80. If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift]"
  81. If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift]"
  82. If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt]"

  83. Else
  84. If Shift = vbShiftMask Then StrCode = "[Shift] + " & StrCode
  85. If Shift = vbCtrlMask Then StrCode = "[Ctrl] + " & StrCode
  86. If Shift = vbAltMask Then StrCode = "[Alt] + " & StrCode
  87. If Shift = vbAltMask + vbCtrlMask Then StrCode = "[Alt + Ctrl] + " & StrCode
  88. If Shift = vbAltMask + vbShiftMask Then StrCode = "[Alt + Shift] + " & StrCode
  89. If Shift = vbCtrlMask + vbShiftMask Then StrCode = "[Ctrl + Shift] + " & StrCode
  90. If Shift = vbCtrlMask + vbShiftMask + vbAltMask Then StrCode = "[Ctrl + Shift +Alt] + " & StrCode
  91. End If

  92. If LCase(StrCode) = LCase(HotKey) Then ' 此段是个键盘HOOK后做出的简单功能,就是隐藏和显示from窗口。
  93. If App.TaskVisible = False Then
  94. Me.Show
  95. App.TaskVisible = True
  96. Else
  97. Me.Hide
  98. App.TaskVisible = False
  99. End If
  100. End If

  101. End Sub

  102. Private Function CodeToString(nCode As Integer) As String
  103. Dim StrKey As String

  104. Select Case nCode
  105. Case vbKeyBack: StrKey = "BackSpace"
  106. Case vbKeyTab: StrKey = "Tab"
  107. Case vbKeyClear: StrKey = "Clear"
  108. Case vbKeyReturn: StrKey = "Enter"
  109. Case vbKeyShift: StrKey = "Shift"
  110. Case vbKeyControl: StrKey = "Ctrl"
  111. Case vbKeyMenu: StrKey = "Alt"
  112. Case vbKeyPause: StrKey = "Pause"
  113. Case vbKeyCapital: StrKey = "CapsLock"
  114. Case vbKeyEscape: StrKey = "ESC"
  115. Case vbKeySpace: StrKey = "SPACEBAR"
  116. Case vbKeyPageUp: StrKey = "PAGE UP"
  117. Case vbKeyPageDown: StrKey = "PAGE DOWN"
  118. Case vbKeyEnd: StrKey = "END"
  119. Case vbKeyHome: StrKey = "HOME"
  120. Case vbKeyLeft: StrKey = "LEFT ARROW"
  121. Case vbKeyUp: StrKey = "UP ARROW"
  122. Case vbKeyRight: StrKey = "RIGHT ARROW"
  123. Case vbKeyDown: StrKey = "DOWN ARROW"
  124. Case vbKeySelect: StrKey = "SELECT"
  125. Case vbKeyPrint: StrKey = "PRINT SCREEN"
  126. Case vbKeyExecute: StrKey = "EXECUTE"
  127. Case vbKeySnapshot: StrKey = "SNAPSHOT"
  128. Case vbKeyInsert: StrKey = "INS"
  129. Case vbKeyDelete: StrKey = "DEL"
  130. Case vbKeyHelp: StrKey = "HELP"
  131. Case vbKeyNumlock: StrKey = "NUM LOCK"
  132. Case vbKey0 To vbKey9: StrKey = Chr$(nCode)
  133. Case vbKeyA To vbKeyZ: StrKey = LCase(Chr$(nCode)) 'MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
  134. Case vbKeyF1 To vbKeyF16: StrKey = "F" & CStr(nCode - 111)
  135. Case vbKeyNumpad0 To vbKeyNumpad9: StrKey = "Numpad " & CStr(nCode - 96)
  136. Case vbKeyMultiply: StrKey = "Numpad {*}"
  137. Case vbKeyAdd: StrKey = "Numpad {+}"
  138. Case vbKeySeparator: StrKey = "Numpad {ENTER}"
  139. Case vbKeySubtract: StrKey = "Numpad {-}"
  140. Case vbKeyDecimal: StrKey = "Numpad {.}"
  141. Case vbKeyDivide: StrKey = "Numpad {/}"
  142. Case Else
  143. StrKey = Chr$(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))) & Str(MapVirtualKeyEx(nCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0))))
  144. End Select
  145. CodeToString = "[" & StrKey & "]"
  146. End Function
复制代码

评分

参与人数 1威望 +2 人气 +1 收起 理由
peace2008 + 2 + 1 精品文章

查看全部评分

 楼主| 发表于 2009-1-11 20:19:48 | 显示全部楼层

  1. 用VB实现“一键上网”
  2. 作者: 冯士全

  3. 常见到联想等品牌机键盘上有很多功能键,可以打开浏览器、字处理等程序,非常方便。那么,兼容机的键盘能实现这些功能吗?当然可以!我们可以通过VB编程,利用小键盘上不常用的键(如“*”、“+”等)实现“一键上网”甚至“一键星际”。

  4. ??大家都知道,在VB中窗体的KeyPreview属性可以对键盘进行控制,但前提是窗体必须具有焦点,也就是在当前窗体下才可以这么做。当窗体不具有焦点时,我们只有设置一个Keyboard Hook来拦截键入的键,从而引发其他程序的运行,下面,我在VB中利用SetWindowsHookEx()函数来实现在窗口不具有焦点时,对键盘的控制,实现“一键上网”。

  5. ??'以下程序是在Module1.bas内

  6. ??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

  7. ??'idHook参数代表拦截的类型,主要有键盘、鼠标等(当拦截键盘输入时值为2)

  8. ??'lpfn参数代表Hook函数的位址

  9. ??'hmod代表.dll的hInstance

  10. ??'dwThreadId代表执行拦截的ThreadId

  11. ??Declare Function UnhookWindowsHookEx Lib""user32""(ByVal hHook As Long)As Long

  12. ??Declare Function CallNextHookEx Lib""user32""(ByVal hHook As Long,ByVal ncode As Long,ByVal wParam As Long,lParam As Any) As Long

  13. ??Public Const WH_KEYBOARD = 2

  14. ??Public hHook As Long

  15. ??Sub EnableHook() '定义EnableHook

  16. ??'设置拦截

  17. ??hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf MyFunc, App.hInstance, 0)

  18. ??End Sub

  19. ??Sub DisableHook()? '定义DisableHook

  20. ??Dim ret As Long

  21. ??ret = UnhookWindowsHookEx(hHook) '取消拦截

  22. ??End Sub

  23. ??Function Myfunc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 'wParam代表按键

  24. ??If wParam=vbKeyAdd Then '判断按键是否为小键盘上的“+”

  25. ??shell ""c:\progra~1\intern~1\iexplore.exe"", vbNormalFocus '执行文件

  26. ??Myfunc=1

  27. ??Exit Function '退出函数,避免循环

  28. ??End if

  29. ??Myfunc=CallNextHookEx(hHook, ncode, wParam, lParam) '传到下一个拦截

  30. ??End Function

  31. ??'下面的程序是在Form内

  32. ??Private Sub Form_Load()

  33. ??Call EnableHook

  34. ??End Sub

  35. ??Private Sub Form_Unload(Cancel As Integer)

  36. ??Call DisableHook

  37. ??End Sub

  38. ??Private Sub Form_Click()

  39. ??'让窗体不可见(也可以把Form1作为Splash屏幕)

  40. ??Form1.Visible = False

  41. ??End Sub

  42. ??程序的框架大概如此,有兴趣的朋友可以完善一下,增加功能键的个数,也可以开个对话框指定功能键和执行的程序,但不要太贪心喽!程序在Windows Me/VB 5.0环境下运行通过。"


复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:21:45 | 显示全部楼层

  1. VB制作不受限制的录音机
  2. 说起录音机程序,大家都会想起Windows自带的那个,但是它有一个非常明显的缺点──有时间限制,录制最长时间不超过60秒,否则就会停下,必须自己按下“录音”键才可以继续录音。

  3.     其实,我们可以用VB来自己编一个不受时间限制的录音机,甚至连Windows API都可以不用就能够实现。下面笔者向大家介绍具体的实现方法:

  4.     1.首先新建一个标准的EXE工程。我们需要两个Label控件,一个MMContrl控件,一个CommonDialog控件,一个Slider控件。两个Label控件分别用来显示录音的总时间和当前的录音时间。MMContrl控件用来支持录音和播放,CommonDialog控件用来打开和保存声音文件,Slider控件是用来直观地显示录音机的状态。

  5.     注:MMContrl控件、CommonDialog控件和Slider控件都不是默认的内部控件,需要添加(在控件工具箱上用右键,选“部件”,在控件列中复选Microsoft Common Dialog Control 6.0(SP3)、Microsoft Multimedia Control 6.0 (SP3)、Microsoft Windows Common Controls 6.0)。

  6.     2.主表单命名为frmMain;把Label控件命名为lblNow和lblTotal,Caption命名为“现在时间”和“总共时间”;把MMContrl控件命名为mci,DeviceType设置为WAVEAudio,FileName设置为c:\windows\temp\~temp.wav(在Windows的临时文件夹中生成临时录音文件,该文件实际上并不存在);把CommonDialog控件命名为cdlg,Filter设置为 声音(波形)文件|*.wav;Slider控件命名为sld,Enable设置为False。

  7.     3.用菜单编辑器给主表单添加菜单,主菜单项只有一个“文件(mnuFile)”,次级菜单有“新建(mnuFileNew)”、“打开(mnuFileOpen)”、“另存为(mnuFileSaveAs)”,“退出(mnuFileExit)”。

  8.     4.一切准备就绪的话,就可以开始了,程序源代码如下:

  9.     Option Explicit

  10.     Dim blnDirty As Boolean

  11.     Dim intResult As Integer

  12.     Private Sub Form_Load()

  13.     mci.Command = ""Open"" '打开准备好的文件

  14.     mci.TimeFormat = 1 '时间格式设置为秒

  15.     blnDirty = False '预先把文件更改设置为否

  16.     End Sub

  17.     Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

  18.     If blnDirty = True Then

  19.     intResult = MsgBox(""需要保存吗?"", vbYesNoCancel + vbQuestion, ""已经有更改!"")

  20.     Select Case intResult

  21.     Case vbYes

  22.     cdlg.CancelError= True  ’把取消错误打开

  23.     On Error GoTo ccancel ’设置错误拦截

  24.     cdlg.ShowSave

  25.     mci.FileName=cdlg.FileName

  26.     mci.Command=""Save""

  27.     frmMain.MousePointer=11

  28.     mci.Command=""close""

  29.     blnDirty=False

  30.     Case vbNo

  31.     mci.Command=""close""

  32.     blnDirty=False

  33.     Case vbCancel

  34.     ccancel:

  35.     Cancel=1

  36.     End Select

  37.     frmMain.mousepointer=0

  38.     End If

  39.     End Sub

  40.     Private Sub mci_RecordClick(Cancel As Integer)

  41.     blnDirty = True

  42.     End Sub

  43.     Private Sub mci_StatusUpdate()

  44.     lblNow.Caption = ""现在时间: "" & mci.Position / 1000 & ""  秒"" '现在时间显示

  45.     lblTotal.Caption = ""总时间: "" & mci.Length / 1000 & ""  秒"" '总共时间显示

  46.     sld.Value = mci.Position / 1000 '滑动条的位置显示

  47.     If mci.Mode = mciModeRecord Then

  48.     If sld.Value = sld.Max Then '自动加时间

  49.     sld.Max=sld.Max + 10

  50.     End If

  51.     End If

  52.     End Sub

  53.     Private Sub mci_StopClick(Cancel As Integer)

  54.     If mci.Mode = mciModeRecord Then

  55.     If sld.Value > 0 Then'期间如果按下了stop键,那么去掉Slider多余的部分

  56.     sld.Max = sld.Value

  57.     End If

  58.     End If

  59.     End Sub

  60.     Private Sub mnuFileExit_Click()

  61.     Unload Me

  62.     End Sub

  63.     Private Sub mnuFileNew_Click()

  64.     If blnDirty = True Then  ’如果正在录音的话

  65.     intResult = MsgBox(""需要保存吗?"", vbYesNo + vbQuestion, ""已经有了修改!"")

  66.     Select Case intResult

  67.     Case vbYes

  68.     cdlg.CancelError = True

  69.     On Error GoTo ccancel

  70.     cdlg.ShowSave

  71.     mci.FileName = cdlg.FileName

  72.     mci.Command = ""Save""

  73.     frmMain.MousePointer = 11

  74.     GoTo ExitFileNew

  75.     Case vbNo

  76.     GoTo ExitFileNew

  77.     End Select

  78.     ccancel:

  79.     Exit Sub

  80.     End If

  81.     ExitFileNew:

  82.     frmMain.MousePointer = 0

  83.     mci.Command = ""close""

  84.     mci.Command = ""open""

  85.     blnDirty = False

  86.     End Sub

  87.     Private Sub mnuFileOpen_Click()

  88.     cdlg.CancelError = True

  89.     On Error GoTo CancelOpen

  90.     cdlg.ShowOpen

  91.     mci.Command = ""close""  ’打开新的文件之前先要关闭已经打开的播放/录音

  92.     mci.FileName = cdlg.FileName

  93.     frmMain.MousePointer = 11

  94.     mci.Command = ""open""

  95.     blnDirty = False

  96.     frmMain.MousePointer = 0

  97.     CancelOpen:

  98.     Exit Sub

  99.     End Sub

  100.     Private Sub mnuFileSaveAs_Click()

  101.     cdlg.Flags=cdlOFNOverwritePrompt+cdlOFNNoChangeDir+cdlOFNHideReadOnly’确认保存是否覆盖原来的文件以及保存的位置是打开的位置、不显示“只读”复选

  102.     cdlg.ShowSave

  103.     mci.FileName = cdlg.FileName

  104.     frmMain.MousePointer = 11

  105.     blnDirty = False

  106.     frmMain.MousePointer = 0

  107.     End Sub

  108. 这样,我们的录音机程序就编写完了。大家还可以在这个基础上按照自己的喜好来做进一步的修改,这个录音机程序不仅可以录音,也可以播放,它是没有录音时间限制的。至于它究竟可以录多久,笔者尝试用它录制了一个长达3个小时的文件,是完全没有问题的。


复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:25:17 | 显示全部楼层

打造自己的英语写作助手


  1. 'module
  2. Option Explicit

  3. Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  4. Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  5. Public Declare Function GetFocus Lib "user32" () As Long
  6. Public Type RECT
  7.     Left As Long
  8.     Top As Long
  9.     Right As Long
  10.     Bottom As Long
  11. End Type
  12. Public Const WM_GETTEXT = &HD
  13. Public Const WM_GETTEXTLENGTH = &HE
  14. Public Const EM_CHARFORMPOS = &HD7


  15. Public 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
  16. Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
  17. Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
  18. Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
  19. Public Const HC_ACTION = 0
  20. Public Const WH_JOURNALRECORD = 0
  21. Public 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
  22. Public Declare Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long
  23. Public Type POINTAPI
  24.     X As Long
  25.     Y As Long
  26. End Type
  27. ' 定义用户自定义的数据类型。
  28. Public Type Record
  29.     ID As Integer
  30.     word As String * 50
  31. End Type

  32. Public focus_rect As RECT
  33. Public hwd As Long
  34. Public haw As Long
  35. Public caret_pos As POINTAPI

  36. '读取函数
  37. Public Function GetWord(pos As Long) As String
  38.     On Error Resume Next
  39.     Dim pos1 As Integer, pos2 As Integer, i As Integer
  40.     Dim strlen As Long
  41.     Dim st() As Byte
  42.     strlen = SendMessage(hwd, WM_GETTEXTLENGTH, 0, 0) + 1
  43.     ReDim st(strlen) As Byte
  44.     SendMessage hwd, WM_GETTEXT, strlen, st(0)

  45.     pos1 = 0: pos2 = UBound(st)

  46.     '向前搜索分格符的位置
  47.     For i = pos - 1 To 0 Step -1
  48.         If IsDelimiter(st(i)) Then
  49.             pos1 = i + 1
  50.             Exit For
  51.         End If
  52.     Next
  53.     '向后搜寻分隔符字符的位置
  54.     For i = pos To UBound(st)
  55.         If IsDelimiter(st(i)) Then
  56.             pos2 = i - 1
  57.             Exit For
  58.         End If
  59.     Next
  60.     '截取pos1-pos2之间的字符,以构成一个单词
  61.     If pos2 > pos1 Then
  62.         ReDim bArr2(pos2 - pos1) As Byte
  63.         For i = pos1 To pos2
  64.             bArr2(i - pos1) = st(i)
  65.         Next
  66.         GetWord = StrConv(bArr2, vbUnicode)
  67.     Else
  68.         GetWord = ""
  69.     End If
  70. End Function

  71. 'IsDelimiter函数
  72. Public Function IsDelimiter(ByVal Char As Byte) As Boolean
  73.     Dim S As String
  74.     S = Chr(Char)
  75.     IsDelimiter = False
  76.     If S = " " Or S = "," Or S = "." Or S = "?" Or S = "vbCr" Or S = "vbLf" Then
  77.         IsDelimiter = True
  78.     End If
  79. End Function

  80. Public Function MyHook(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  81.     Dim i As Long
  82.     Dim pos As Long
  83.     Dim carpos As Long
  84.     Dim lc As Long
  85.     If ncode = HC_ACTION Then
  86.         hwd = GetFocus()
  87.         If hwd <> Form1.hwnd And hwd <> Form1.List1.hwnd Then
  88.             GetWindowRect hwd, focus_rect
  89.             GetCaretPos caret_pos
  90.             Form1.Top = (focus_rect.Top + caret_pos.Y + 20) * Screen.TwipsPerPixelY
  91.             Form1.Left = (focus_rect.Left + caret_pos.X + 10) * Screen.TwipsPerPixelX
  92.             pos = caret_pos.X + caret_pos.Y * 65536
  93.             carpos = SendMessage(hwd, EM_CHARFORMPOS, 0, ByVal pos)
  94.             lc = carpos Mod 65536

  95.             If Form1.Caption <> GetWord(lc) Then
  96.                 Form1.Caption = GetWord(lc)
  97.                 '把文件file.wrd中的内容装入列表框中
  98.                 Dim myrecord As Record
  99.                 If Form1.Caption <> "" Then
  100.                     Form1.List1.Clear
  101.                     Open "file.wrd" For Random As #1 Len = Len(myrecord)
  102.                     For i = 1 To LOF(1) / Len(myrecord)
  103.                         Get #1, i, myrecord
  104.                         If Form1.Caption = Left(myrecord.word, Len(Form1.Caption)) Then Form1.List1.AddItem myrecord.word
  105.                     Next i
  106.                     Close #1
  107.                 End If
  108.             End If
  109.         End If
  110.     Else
  111.         CallNextHookEx haw, ncode, wParam, lParam
  112.     End If
  113.     CallNextHookEx haw, ncode, wParam, lParam
  114. End Function
  115.                         
复制代码

  1. Option Explicit

  2. Private Sub addword_Click()
  3.     '往file.wrd文件中添加单词
  4.     Dim myrecord As Record
  5.     Dim addwrd As String
  6.     addwrd = InputBox("是否要把" & Form1.Caption & "这个单词添加进文件中吗?", "添加单词", Form1.Caption)
  7.     Open "file.wrd" For Random As #1 Len = Len(myrecord)
  8.     myrecord.ID = LOF(1) / Len(myrecord) + 1
  9.     myrecord.word = addwrd
  10.     Put #1, myrecord.ID, myrecord
  11.     Close #1
  12. End Sub

  13. Private Sub Form_Load()
  14.     '固定界面
  15.     SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
  16.     '设置界面的长和宽
  17.     Form1.Width = List1.Width
  18.     Form1.Height = List1.Height
  19.     '使用钩子函数
  20.     haw = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf MyHook, App.hInstance, 0)
  21. End Sub

  22. Private Sub Form_Unload(Cancel As Integer)
  23.     '退出程序
  24.     UnhookWindowsHookEx haw
  25.     Unload Me
  26.     End
  27. End Sub

  28. Private Sub helps_Click()
  29.     MsgBox "这个程序能够帮助你在写" + Chr(13) + "英文时,动态地对你的拼写" + Chr(13) + "给出提示!", , "帮助"
  30. End Sub

  31. Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  32.     '单击右键,弹出子菜单
  33.     If Button = vbRightButton Then Form1.PopupMenu cd
  34. End Sub

复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:28:18 | 显示全部楼层

极力推荐的窗口处理技巧


  1. 窗口处理技巧大全
  2.      Vb提供了API函数SetWindowLong和GetWindowLong,可以让我们很容易取得对窗口的操作;通过对窗口属性的操作,可以更改窗口的显示风格。有些看来是正常情况下无法实现的窗口,现在你可以很容易的实现。只要你想到,更多希奇古怪的你也能做到。快试试下面的例子吧。



  3.     一下例子中可能用到的API声明和常量、变量声明
  4.     Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  5.     Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  6.     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
  7.     Private Const SWP_NOSIZE = &H1
  8.     Private Const SWP_NOZORDER = &H4
  9.     Private Const SWP_NOMOVE = &H2
  10.     Private Const SWP_DRAWFRAME = &H20
  11.     Private Const GWL_STYLE = (-16)
  12.     Private Const WS_THICKFRAME = &H40000
  13.     Private Const WS_DLGFRAME = &H400000
  14.     Private Const WS_POPUP = &H80000000
  15.     Private Const WS_CAPTION = &HC00000
  16.     Private Const WS_SYSMENU = &H80000
  17.     Private Const WS_MINIMIZEBOX = &H20000
  18.     Private Const WS_MAXIMIZEBOX = &H10000
  19.     Private Const WS_MINIMIZE = &H20000000
  20.     Private Const WS_MAXIMIZE = &H1000000



  21. --------------------------------------------------------------------------------

  22.     例子一:任何一个控件(只要有窗口,这是我们的前提,下同),你可以在运行时随便更改它的大小。     
  23.     Private Sub ControlSize(ControlName As Control, SetTrue As Boolean)
  24.     Dim dwStyle As Long
  25.     dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
  26.     If SetTrue Then
  27.         dwStyle = dwStyle Or WS_THICKFRAME
  28.     Else
  29.         dwStyle = dwStyle - WS_THICKFRAME
  30.     End If
  31.     dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
  32.     SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
  33.     End Sub
  34.     用法:ControlSize picture1,true;设置第二个参数为False取消这种设置,下同



  35. --------------------------------------------------------------------------------

  36.     例子二:任何一个控件,我们都可以控制其显示风格为对话框的风格。
  37.     Private Sub ControlDialog(ControlName As Control, SetTrue As Boolean)
  38.     Dim dwStyle As Long
  39.     dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
  40.     If SetTrue Then
  41.         dwStyle = dwStyle Or WS_DLGFRAME
  42.     Else
  43.         dwStyle = dwStyle - WS_DLGFRAME
  44.     End If
  45.     dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
  46.     SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
  47.     End Sub
  48.     用法:ControlSize picture1,true



  49. --------------------------------------------------------------------------------

  50.     例子三:任何一个控件,我们都可以控制其显示风格为模式对话框的风格
  51.     Private Sub ControlModal(ControlName As Control, SetTrue As Boolean)
  52.     Dim dwStyle As Long
  53.     dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
  54.     If SetTrue Then
  55.         dwStyle = dwStyle Or WS_POPUP
  56.     Else
  57.         dwStyle = dwStyle - WS_POPUP
  58.     End If
  59.     dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
  60.     SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
  61.     End Sub
  62.     用法:ControlModal Picture1,true



  63. --------------------------------------------------------------------------------

  64.     例子四:任何一个控件,我们都可以给它加上标题栏,通过拖动标题栏,可以实现控件的运行时移动。
  65.     Private Sub ControlCaption(ControlName As Control, SetTrue As Boolean)
  66.     Dim dwStyle As Long
  67.     dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
  68.     If SetTrue Then
  69.         dwStyle = dwStyle Or WS_CAPTION
  70.     Else
  71.         dwStyle = dwStyle - WS_CAPTION
  72.     End If
  73.     dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
  74.     SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
  75.     End Sub
  76.     用法:ControlCaption picture1,true



  77. --------------------------------------------------------------------------------

  78.     例子五:任何一个控件,我们都可以给它加上ControlBox(所谓ControlBox,就是窗体的图标+最小化+最大化+关闭按钮)。
  79.     Private Sub ControlSysMenu(ControlName As Control, SetTrue As Boolean)
  80.     Dim dwStyle As Long
  81.     dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
  82.     If SetTrue Then
  83.         dwStyle = dwStyle Or WS_SYSMENU
  84.     Else
  85.         dwStyle = dwStyle - WS_SYSMENU
  86.     End If
  87.     dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
  88.     SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
  89.     End Sub
  90.     用法:ControlCaption picture1,true:ControlSysmenu picture1,true


复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:31:31 | 显示全部楼层

得到打印机低张信息


  1. 办法如下:

  2. Option Explicit
  3. Private Const DC_MAXEXTENT = 5
  4. Private Const DC_MINEXTENT = 4
  5. Private Const DC_PAPERNAMES = 16
  6. Private Const DC_PAPERS = 2
  7. Private Const DC_PAPERSIZE = 3
  8. 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
  9. Private Type POINTS
  10. x As Long
  11. y As Long
  12. End Type

  13. '***********************************************************
  14. '* 名称:GetPaperInfo
  15. '* 功能:得到打印机低张信息
  16. '* 用法:GetPaperInfo(控件名)
  17. '* 描述:如在 form_load()中调用GetPaperInfo MSHFlexGrid1
  18. '***********************************************************
  19. Public Function GetPaperInfo(Flex As MSHFlexGrid) As Boolean

  20. Dim i As Long, ret As Long
  21. Dim Length As Integer, Width As Integer
  22. Dim PaperNo() As Integer, PaperName() As String, PaperSize() As POINTS

  23. With Flex
  24. .FormatString = "^纸张编号|^纸张名称|^纸张长度|^纸张宽度"
  25. For i = 0 To .Cols - 1
  26. .ColWidth(i) = 1700
  27. Next i
  28. .AllowUserResizing = flexResizeColumns
  29. .Left = 0
  30. End With

  31. '支持最大打印纸:
  32. ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_MAXEXTENT, ByVal 0&, ByVal 0&)
  33. Length = ret 65536
  34. Width = ret - Length * 65536

  35. '支持最小打印纸:
  36. ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_MINEXTENT, ByVal 0&, ByVal 0&)
  37. Length = ret 65536
  38. Width = ret - Length * 65536

  39. '支持纸张种类数
  40. ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, ByVal 0&, ByVal 0&)

  41. '纸张编号
  42. ReDim PaperNo(1 To ret) As Integer
  43. Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, PaperNo(1), ByVal 0&)

  44. '纸张名称
  45. Dim arrPageName() As Byte
  46. Dim allNames As String
  47. Dim lStart As Long, lEnd As Long
  48. ReDim PaperName(1 To ret) As String
  49. ReDim arrPageName(1 To ret * 64) As Byte
  50. Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERNAMES, arrPageName(1), ByVal 0&)
  51. allNames = StrConv(arrPageName, vbUnicode)
  52. 'loop through the string and search for the names of the papers
  53. i = 1
  54. Do
  55. lEnd = InStr(lStart + 1, allNames, Chr$(0), vbBinaryCompare)
  56. If (lEnd > 0) And (lEnd - lStart - 1 > 0) Then
  57. PaperName(i) = Mid$(allNames, lStart + 1, lEnd - lStart - 1)
  58. i = i + 1
  59. End If
  60. lStart = lEnd
  61. Loop Until lEnd = 0

  62. '纸张尺寸

  63. ReDim PaperSize(1 To ret) As POINTS
  64. Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERSIZE, PaperSize(1), ByVal 0&)

  65. '显示在表格中
  66. For i = 1 To ret
  67. Flex.AddItem PaperNo(i) & vbTab & PaperName(i)
  68. & vbTab & PaperSize(i).y & vbTab & PaperSize(i).x
  69. Next i

  70. End Function



复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:33:53 | 显示全部楼层

如何用VB实现真正的多线程而不是进程

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

2.线程函数里不能有VB的内置函数,比如left,trim等
 
3.创建线程CreateThread的参数不要使用ByVal &0,使用变量

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

评分

参与人数 1威望 +2 金钱 +2 收起 理由
VBProFan + 2 + 2 好贴

查看全部评分

回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:36:11 | 显示全部楼层

控件大小随窗体改变而变,包括字体


  1. Option Explicit

  2. Public initwidth As Integer
  3. Public InitHeight As Integer

  4. Public Function loadFrm(frm As Form)
  5. initwidth = frm.ScaleWidth
  6. InitHeight = frm.ScaleHeight
  7. Dim Ctl As Control '记录每个Control的原始位置、大小、字型大小,放在Tag属性中
  8. On Error Resume Next '确保left,top,width,height,Tag属性没有全有的Control
  9. For Each Ctl In frm '也能正常执行
  10. Ctl.Tag = Ctl.Left & "   " & Ctl.Top & "   " & Ctl.Width & "   " & Ctl.Height & "   "
  11. Ctl.Tag = Ctl.Tag & Ctl.FontSize & "   "
  12. Next Ctl
  13. On Error GoTo 0
  14. End Function

  15. Public Function resizeFrm(frm As Form)
  16. '窗体控件及字体随窗体大小变化代码
  17. Dim D(4) As Double
  18. Dim i As Long
  19. Dim TempPos As Long
  20. Dim StartPos As Long
  21. Dim Ctl As Control
  22. Dim TempVisible As Boolean
  23. Dim ScaleX As Double
  24. Dim ScaleY As Double
  25.    
  26. ScaleX = frm.ScaleWidth / initwidth
  27. ScaleY = frm.ScaleHeight / InitHeight
  28. On Error Resume Next
  29. For Each Ctl In frm
  30.   TempVisible = Ctl.Visible
  31.   Ctl.Visible = False
  32.   StartPos = 1
  33.   ' 读取 Control 的原始位置、大小、字型大小
  34.   For i = 0 To 4
  35.       TempPos = InStr(StartPos, Ctl.Tag, "   ", vbTextCompare)
  36.       If TempPos > 0 Then
  37.       D(i) = Mid(Ctl.Tag, StartPos, TempPos - StartPos)
  38.       StartPos = TempPos + 1
  39.       Else
  40.       D(i) = 0
  41.       End If
  42.       ' 根据比例设定 Control 的位置、大小、字型大小
  43.       Ctl.Move D(0) * ScaleX, D(1) * ScaleY, D(2) * ScaleX, D(3) * ScaleY
  44.       'Ctl.Width = D(2) * ScaleX
  45.       'Ctl.Height = D(3) * ScaleY
  46.       If ScaleX < ScaleY Then
  47.       Ctl.FontSize = D(4) * ScaleX
  48.       Else
  49.       Ctl.FontSize = D(4) * ScaleY
  50.       End If
  51.   Next i
  52.   Ctl.Visible = TempVisible
  53. Next Ctl
  54. On Error GoTo 0
  55. End Function
复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:37:29 | 显示全部楼层

右下角弹出窗体代码


  1. '-------------------------------------------------------------
  2. '透明
  3. Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
  4. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  5. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  6. Const WS_EX_LAYERED = &H80000
  7. Const GWL_EXSTYLE = (-20)
  8. Const LWA_ALPHA = &H2
  9. Const LWA_COLORKEY = &H1

  10. '延迟
  11. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

  12. '最前
  13. 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
  14. Private Const HWND_BOTTOM = 1
  15. Private Const HWND_BROADCAST = &HFFFF&
  16. Private Const HWND_DESKTOP = 0
  17. Private Const HWND_NOTOPMOST = -2
  18. Private Const HWND_TOP = 0
  19. Private Const HWND_TOPMOST = -1

  20. '可见区域
  21. Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  22. Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
  23. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

  24. Dim MyRect As Long
  25. Dim MyRgn As Long

  26. Dim X1 As Integer, Y1 As Integer
  27. Dim X2 As Integer, Y2 As Integer
  28. Dim OpenSpeed As Integer
  29. Dim CloseSpeed As Integer

  30. Dim WiteLong As Integer


  31. Private Sub Form_Load()
  32. Text1.Text = "*******提示窗口*******" & vbCrLf & "******* Line1 *******" & vbCrLf & "******* Line2 *******" & vbCrLf & "******* Line3 *******" & vbCrLf & "******* Line4 *******" & vbCrLf & "******* Line5 *******" & vbCrLf & "******* Line6 *******"
  33. '------------------------------------------------------------------
  34.    OpenSpeed = 10          '出现时速度
  35.    CloseSpeed = 10         '关闭时淡出的速度
  36.    Timer1.Interval = 10    '出现时显示平滑度
  37.    WiteLong = 30           '关闭前等待时间(秒),为0则不会自动关闭
  38. '------------------------------------------------------------------
  39.    
  40.    Me.Move Screen.Width * 0.75, Screen.Height * 0.75, _
  41.            Screen.Width \ 4, Screen.Height \ 4
  42.    
  43.    SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left \ Screen.TwipsPerPixelX, Me.Top \ Screen.TwipsPerPixelY, Me.Width, Me.Height, 1

  44.    X1 = 0
  45.    Y1 = Me.Width \ Screen.TwipsPerPixelX
  46.    
  47.    X2 = Me.Width \ Screen.TwipsPerPixelX
  48.    Y2 = Me.Height \ Screen.TwipsPerPixelY - 1
  49.    
  50.    MyRect = CreateRectRgn(X1, Y1, X2, Y2)
  51.    MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
  52. End Sub

  53. Private Sub Form_Unload(Cancel As Integer)
  54.    Call CloseMe(1)   '以什么样的方式关闭自己,有 1-淡出 和 2-收缩 可选
  55.    Call DeleteObject(MyRect)
  56. End Sub


  57. Private Sub Timer1_Timer()
  58.    Y2 = Y2 - OpenSpeed
  59.    
  60.    If Y2 <= 0 Then
  61.      MyRect = CreateRectRgn(0, 0, Me.Width \ Screen.TwipsPerPixelX, Y2)
  62.      MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
  63.      
  64.      Timer1.Enabled = False
  65.      
  66.      '----------------------
  67.      If WiteLong <> 0 Then
  68.        Timer2.Interval = 1000
  69.        Timer2.Enabled = True
  70.      End If
  71.    End If
  72.    
  73.    MyRect = CreateRectRgn(X1, Y1, X2, Y2)
  74.    MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
  75. End Sub

  76. Private Sub Timer2_Timer()
  77.    Static NL As Integer
  78.    NL = NL + 1
  79.    
  80.    If NL >= WiteLong Then Unload Me
  81.    
  82. End Sub


  83. '==============================================
  84. '0 - 不使用卸载效果
  85. '1 - 使用透明淡出效果
  86. '2 - 使用收缩效果
  87. '==============================================
  88. Private Sub CloseMe(Optional N As Integer = 1)
  89. Select Case N
  90.    Case 0
  91.      Exit Sub
  92.    Case 1
  93.      Dim rtn As Long
  94.      
  95.      rtn = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
  96.      rtn = rtn Or WS_EX_LAYERED
  97.      SetWindowLong Me.hWnd, GWL_EXSTYLE, rtn
  98.      
  99.      For I = 255 To 10 Step -10
  100.        SetLayeredWindowAttributes Me.hWnd, 0, I, LWA_ALPHA
  101.        DoEvents
  102.        Sleep CloseSpeed
  103.      Next I
  104.    Case 2
  105.      While Y2 < (Me.Height / Screen.TwipsPerPixelY)
  106.        Y2 = Y2 + OpenSpeed
  107.        MyRect = CreateRectRgn(X1, Y1, X2, Y2)
  108.        MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
  109.        Sleep OpenSpeed
  110.      Wend
  111.    Case Else
  112.    
  113. End Select
  114. End Sub



复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2009-1-11 20:39:01 | 显示全部楼层

Combo的自动查询技术


  1. Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
  2. hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
  3. As Long
  4. Public Const CB_FINDSTRING = &H14C
  5. Private Sub Combo1_Change()
  6. Dim iStart As Integer
  7. Dim sString As String
  8. Static iLeftOff As Integer
  9. iStart = 1
  10. iStart = Combo1.SelStart
  11. If iLeftOff <> 0 Then
  12. Combo1.SelStart = iLeftOff
  13. iStart = iLeftOff
  14. End If
  15. sString = CStr(Left(Combo1.Text, iStart))
  16. Combo1.ListIndex = SendMessage(Combo1.hwnd,B_FINDSTRING, -1, ByVal CStr(
  17. Left( ombo1.Text, iStart)))
  18.  
  19. If Combo1.ListIndex = -1 Then
  20. iLeftOff = Len(sString)
  21. combo1.Text = sString
  22. End If
  23. Combo1.SelStart = iStart
  24. iLeftOff = 0
  25. End Sub
  26. 静态变量 iLeftOff 指定了字符长度。
复制代码
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-6-29 20:35

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表