vb±à³Ì68Àý - VBA/VB/ActiveX/API ±à³Ì¼¼Êõ - AutoCADÂÛÌ³ - Ã÷¾CADÉçÇø - µÚ2Ò³

yulijin608 ·¢±íÓÚ 2005-1-6 11:44:00

41. ÐÞ¸Ä´°ÌåÏµÍ³²Ëµ¥ module: Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long Public Const WM_SYSCOMMAND = &H112 Public Const GWL_WNDPROC = (-4) Public Const MF_STRING = &H0& Public Const MF_SEPARATOR = &H800& Public OldWindowProc As Long ' ±£´æÄ¬ÈÏµÄ´°¿Úº¯ÊýµØÖ· Public SysMenuHwnd As Long Public Function SubClass1_WndMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long If Msg <> WM_SYSCOMMAND Then SubClass1_WndMessage = CallWindowProc(OldWindowProc, hwnd, Msg, wp, lp) ' Èç¹ûÏûÏ¢²»ÊÇWM_SYSCOMMAND£¬¾Íµ÷ÓÃÄ¬ÈÏµÄ´°¿Úº¯Êý´¦Àí Exit Function End If Select Case wp Case 2001 Call MsgBox("±¾³ÌÐòÊµÏÖÁËÐÞ¸ÄÏµÍ³²Ëµ¥µÄ¹¦ÄÜ ", vbOKOnly + vbInformation) Case 2003 Call GetSystemMenu(Form1.hwnd, True) Call SetWindowLong(Form1.hwnd, GWL_WNDPROC, OldWindowProc) Call MsgBox("ÒÑ¾»Ö¸´ÁËÄ¬ÈÏµÄÏµÍ³²Ëµ¥ ", vbOKOnly + vbInformation) Case Else SubClass1_WndMessage = CallWindowProc(OldWindowProc, hwnd, Msg, wp, lp) Exit Function End Select SubClass1_WndMessage = True End Function ´°Ìå£º Private Sub Form_Load() OldWindowProc = GetWindowLong(Form1.hwnd, GWL_WNDPROC) ' È¡µÃ´°¿Úº¯ÊýµÄµØÖ· Call SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf SubClass1_WndMessage) ' ÓÃSubClass1_WndMessage´úÌæ´°¿Úº¯Êý´¦ÀíÏûÏ¢ SysMenuHwnd = GetSystemMenu(Form1.hwnd, False) Call AppendMenu(SysMenuHwnd, MF_SEPARATOR, 2000, vbNullString) Call AppendMenu(SysMenuHwnd, MF_STRING, 2001, "¹ØÓÚ±¾³ÌÐò(&A)") Call AppendMenu(SysMenuHwnd, MF_SEPARATOR, 2002, vbNullString) Call AppendMenu(SysMenuHwnd, MF_STRING, 2003, "»Ö¸´ÏµÍ³²Ëµ¥(&R)") End Sub Private Sub Form_Unload(Cancel As Integer) If OldWindowProc <> GetWindowLong(Form1.hwnd, GWL_WNDPROC) Then Call SetWindowLong(Form1.hwnd, GWL_WNDPROC, OldWindowProc) End If End Sub 42.ÈçºÎÔÚÐ¡»ÃæÉÏÏÔÊ¾´óÍ¼Æ¬ ·½·¨Ò»£º Ò»¸öpicturebox¿Ø¼þ£¬Ò»¸öimage¿Ø¼þ£¨ÒÔpictureboxÎªÈÝÆ÷£©£¬Í¼Æ¬¼ÓÔØÔÚimageÖÐ£¬Ò»¸öHScroll1£¬VScroll1£¨ÒÔpictureboxÎªÈÝÆ÷£©¡£ Private Sub Bar1_Change() Image1.Left = -bar1.Value End Sub

Private Sub Bar2_Change() Image1.Top = -Bar2.Value End Sub

Private Sub Form_Load() Image1.Left = 0 Image1.Top = 0 bar1.SmallChange = 300 Bar2.SmallChange = 300 bar1.Max = Image1.Width - Picture1.Width Bar2.Max = Image1.Height - Picture1.Height bar1.Min = 0 Bar2.Min = 0 End Sub

 ·½·¨¶þ£ºÀûÓÃÊó±êÒÆ¶¯Í¼Æ¬ Ò»¸öpicturebox¿Ø¼þ£¬Ò»¸öimage¿Ø¼þ£¨ÒÔpictureboxÎªÈÝÆ÷£©£¬Í¼Æ¬¼ÓÔØÔÚimageÖÐ Dim ix As Integer Dim iy As Integer Private Sub Form_Load() Image1.Left = 0 Image1.Top = 0 End Sub Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Then ix = X iy = Y End If End Sub Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim ipx As Integer Dim ipy As Integer If Button = vbLeftButton Then ipx = Image1.Left + X - ix ipy = Image1.Top + Y - iy If ipx > 0 Then Image1.Left = 0 Else If ipx < Picture1.Width - Image1.Width Then ipx = Picture1.Width - Image1.Width Else Image1.Left = ipx End If End If If ipy > 0 Then Image1.Top = 0 Else If ipy < Picture1.Height - Image1.Height Then ipy = Picture1.Height - Image1.Height Else Image1.Top = ipy End If End If End If End Sub Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.MousePointer = 0 End Sub

43. Ê¹´°Ìå²»³öÆÁÄ»×ó±ß½ç module: Option Explicit Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long

Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _ lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Public Const GWL_WNDPROC = (-4) Public Const WM_WINDOWPOSCHANGING = &H46 Type WINDOWPOS hwnd As Long hWndInsertAfter As Long x As Long y As Long cx As Long cy As Long flags As Long End Type Public preWinProc As Long '¶øÖØµã¾ÍÔÚì¶WindowÖØÐÂ¶¨Î»Ö®Ç°»á´« '³öWM_WINDOWPOSCHANGINGÕâ¸öÑ¶Ï¢£¬¶ølParamÖ¸ÏòÒ»¸öWINDOWPOSµÄSTRUCTURE¡£ Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Dim lwd As Long, hwd As Long If Msg = WM_WINDOWPOSCHANGING Then Dim WPOS As WINDOWPOS CopyMemory WPOS, ByVal lParam, Len(WPOS) If WPOS.x < 0 Then WPOS.x = 0 CopyMemory ByVal lParam, WPOS, Len(WPOS) End If End If '½«Ö®ËÍÍùÔÀ´µÄWindow Procedure wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam) End Function ´°ÌåÖÐ Sub Form_Load() Dim ret As Long '¼ÇÂ¼Ô±¾µÄWindow ProcedureµÄÎ»Ö· preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC) ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc) End Sub

Private Sub Form_Unload(Cancel As Integer) Dim ret As Long 'È¡ÏûMessageµÄ½ØÈ¡£¬¶øÊ¹Ö®ÓÖÖ»ËÍÍùÔÀ´µÄWindow Procedure ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc) End Sub 44.´ò¿ªÖ¸¶¨µÄ´°Ìå Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Const SW_SHOWNORMAL = 1 Private Sub Command1_Click() 'ÎÒµÄÎÄµµ ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1 End Sub Private Sub Command2_Click() 'ÎÒµÄµçÄÔ ShellExecute Me.hwnd, "open", "explorer", "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1 End Sub Private Sub Command3_Click() 'ÍøÉÏÁÚ¾Ó ShellExecute Me.hwnd, "open", "explorer", "::{208d2c60-3aea-1069-a2d7-08002b30309d}", vbNullString, 1 End Sub Private Sub Command4_Click() '»ØÊÕÕ¾ ShellExecute Me.hwnd, "open", "explorer", "::{645ff040-5081-101b-9f08-00aa002f954e}", vbNullString, 1 End Sub Private Sub Command5_Click() '¿ØÖÆÃæ°å ShellExecute Me.hwnd, "open", "explorer", "::{21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1 End Sub Private Sub Command6_Click() '´ò¿ªÖ¸¶¨µÄÂ·¾¶ ShellExecute Me.hwnd, "open", "D:\vbÁ·Ï°ÊÂÀý", vbNullString, vbNullString, 1 End Sub Private Sub Command7_Click() 'ÒôÁ¿¿ØÖÆ Shell "sndvol32.exe", vbNormalFocus End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 11:47:00

45.´°Ìå·Ö¸îÌõ

splitterÎªÒ»picturebox¿Ø¼þ¡£ Option Explicit Private Const SPLT_WDTH As Integer = 35 Private currSplitPosX As Long Dim CTRL_OFFSET As Integer Dim SPLT_COLOUR As Long Private Sub Form_Load() CTRL_OFFSET = 5 SPLT_COLOUR = &H808080 currSplitPosX = &H7FFFFFFF ListLeft.AddItem "VB¾ãÀÖ²¿" ListLeft.AddItem "VB¶¯»Æª" ListLeft.AddItem "VBÍøÂçÆª" ListLeft.AddItem "VB¿Ø¼þÀà" ListLeft.AddItem "VB½çÃæÀà" TextRight = "¾³£¼ûµ½´°ÌåÉÏÓÐ¶þ¸öÏàÁÚµÄÁÐ±í¿ò£¬¿ÉÒÔÓÃÊó±êÈÎÒâÀ¶¯ÖÐ¼ä·Ö¸îÌõ£¬¸Ä±äÁÐ±í¿ò´óÐ¡¡£" End Sub Private Sub Form_Resize() Dim x1 As Integer Dim x2 As Integer Dim height1 As Integer Dim width1 As Integer Dim width2 As Integer On Error Resume Next height1 = ScaleHeight - (CTRL_OFFSET * 2) x1 = CTRL_OFFSET width1 = ListLeft.Width x2 = x1 + ListLeft.Width + SPLT_WDTH - 1 width2 = ScaleWidth - x2 - CTRL_OFFSET ListLeft.Move x1% - 1, CTRL_OFFSET, width1, height1 TextRight.Move x2, CTRL_OFFSET, width2 + 1, height1 Splitter.Move x1 + ListLeft.Width - 1, CTRL_OFFSET, SPLT_WDTH, height1 End Sub Private Sub Splitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbLeftButton Then Splitter.BackColor = SPLT_COLOUR currSplitPosX = CLng(X) Else If currSplitPosX <> &H7FFFFFFF Then Splitter_MouseUp Button, Shift, X, Y currSplitPosX = &H7FFFFFFF End If End Sub Private Sub Splitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If currSplitPosX& <> &H7FFFFFFF Then If CLng(X) <> currSplitPosX Then Splitter.Move Splitter.Left + X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2) currSplitPosX = CLng(X) End If End If End Sub Private Sub Splitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If currSplitPosX <> &H7FFFFFFF Then If CLng(X) <> currSplitPosX Then Splitter.Move Splitter.Left + X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2) End If currSplitPosX = &H7FFFFFFF Splitter.BackColor = &H8000000F If Splitter.Left > 60 And Splitter.Left < (ScaleWidth - 60) Then ListLeft.Width = Splitter.Left - ListLeft.Left ElseIf Splitter.Left < 60 Then ListLeft.Width = 60 Else ListLeft.Width = ScaleWidth - 60 End If Form_Resize End If

End Sub

 46.ÍÐÅÌ³ÌÐò module: Option Explicit Public preWinProc As Long Public NewForm As Form Public NewMenu As Menu Public Const WM_USER = &H400 Public Const WM_LBUTTONUP = &H202 Public Const WM_MBUTTONUP = &H208 Public Const WM_RBUTTONUP = &H205 Public Const TRAY_CALLBACK = (WM_USER + 1001&) Public Const GWL_WNDPROC = (-4) Public Const GWL_USERDATA = (-21) Public Const NIF_ICON = &H2 Public Const NIF_TIP = &H4 Public Const NIM_ADD = &H0 Public Const NIF_MESSAGE = &H1 Public Const NIM_MODIFY = &H1 Public Const NIM_DELETE = &H2 Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long Public Type NOTIFYICONDATA cbSize As Long hwnd As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 64 End Type Private NOTI As NOTIFYICONDATA Public Function NewWindone(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = TRAY_CALLBACK Then If lParam = WM_LBUTTONUP Then ' µ¥»÷×ó¼ü£¬µ¯³ö´°¿Ú If NewForm.WindowState = vbMinimized Then _ NewForm.WindowState = NewForm.LastState NewForm.SetFocus Exit Function End If If lParam = WM_RBUTTONUP Then ' µ¥»÷ÓÒ¼ü£¬µ¯³ö²Ëµ¥ NewForm.PopupMenu NewMenu Exit Function End If End If NewWindone = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam) End Function Public Sub AddToTray(frm As Form, mnu As Menu) Set NewForm = frm Set NewMenu = mnu preWinProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindone) With NOTI .uID = 0 .hwnd = frm.hwnd .cbSize = Len(NOTI) .hIcon = frm.Icon.Handle .uFlags = NIF_ICON .uCallbackMessage = TRAY_CALLBACK .uFlags = .uFlags Or NIF_MESSAGE .cbSize = Len(NOTI) End With Shell_NotifyIcon NIM_ADD, NOTI End Sub 'ÆÁ±ÎÍÐÅÌ Public Sub RemoveFromTray() With NOTI .uFlags = 0 End With Shell_NotifyIcon NIM_DELETE, NOTI SetWindowLong NewForm.hwnd, GWL_WNDPROC, preWinProc End Sub

Public Sub SetTrayTip(tip As String) With NOTI .szTip = tip & vbNullChar .uFlags = NIF_TIP End With Shell_NotifyIcon NIM_MODIFY, NOTI End Sub

Public Sub SetTrayIcon(pic As Picture) If pic.Type <> vbPicTypeIcon Then Exit Sub With NOTI .hIcon = pic.Handle .uFlags = NIF_ICON End With Shell_NotifyIcon NIM_MODIFY, NOTI End Sub ´°ÌåÖÐ

Private Sub Form_Load() AddToTray Me, Tray SetTrayTip "ÍÐÅÌÑÝÊ¾" End Sub Private Sub Form_Unload(Cancel As Integer) RemoveFromTray End Sub 47.ledÊýÖµÏÔÊ¾ Ìí¼ÓÀàÄ£¿é£º£¨nameÊôÐÔÎªmcLCD£© Option Explicit Private Type Coordinate X As Integer Y As Integer End Type Dim BasePoint As Coordinate Dim SegWidth As Integer Dim SegHeight As Integer Dim p As PictureBox Property Let BackColor(Color As Long) p.BackColor = Color End Property Private Sub DrawNumber(Number As Integer) Select Case Number Case 0 DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4) DrawSegment (5): DrawSegment (6) Case 1 DrawSegment (2): DrawSegment (3) Case 2 DrawSegment (1): DrawSegment (2): DrawSegment (7): DrawSegment (5) DrawSegment (4) Case 3 DrawSegment (1): DrawSegment (2): DrawSegment (7): DrawSegment (3) DrawSegment (4) Case 4 DrawSegment (2): DrawSegment (3): DrawSegment (7): DrawSegment (6) Case 5 DrawSegment (1): DrawSegment (6): DrawSegment (7): DrawSegment (3) DrawSegment (4) Case 6 DrawSegment (1): DrawSegment (6): DrawSegment (7): DrawSegment (3) DrawSegment (4): DrawSegment (5) Case 7 DrawSegment (1): DrawSegment (2) DrawSegment (3) Case 8 DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4) DrawSegment (5): DrawSegment (6): DrawSegment (7) Case 9 DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4) DrawSegment (6): DrawSegment (7) End Select End Sub Private Sub DrawSegment(SegNum As Integer) ' 1 ' ___ ' | | ' 6 | | 2 ' |-7-| ' 5 | | 3 ' |___| ' ' 4 '»³öÆß¶ÎÊýÂë¹ÜµÄÆß¸ö×é³É²¿·Ö Select Case SegNum Case 1 p.Line (BasePoint.X + 1, BasePoint.Y)-(BasePoint.X + SegWidth - 1, BasePoint.Y) p.Line (BasePoint.X + 2, BasePoint.Y + 1)-(BasePoint.X + SegWidth - 2, BasePoint.Y + 1) p.Line (BasePoint.X + 3, BasePoint.Y + 2)-(BasePoint.X + SegWidth - 3, BasePoint.Y + 2) Case 2 p.Line (BasePoint.X + SegWidth - 1, BasePoint.Y + 1)-(BasePoint.X + SegWidth - 1, BasePoint.Y + (SegHeight \ 2) - 1) p.Line (BasePoint.X + SegWidth - 2, BasePoint.Y + 2)-(BasePoint.X + SegWidth - 2, BasePoint.Y + (SegHeight \ 2)) p.Line (BasePoint.X + SegWidth - 3, BasePoint.Y + 3)-(BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) - 1) Case 3 p.Line (BasePoint.X + SegWidth - 1, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X + SegWidth - 1, BasePoint.Y + SegHeight) p.Line (BasePoint.X + SegWidth - 2, BasePoint.Y + (SegHeight \ 2) + 1)-(BasePoint.X + SegWidth - 2, BasePoint.Y + SegHeight - 1) p.Line (BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X + SegWidth - 3, BasePoint.Y + SegHeight - 2) Case 4 p.Line (BasePoint.X + 3, BasePoint.Y + SegHeight - 2)-(BasePoint.X + SegWidth - 3, BasePoint.Y + SegHeight - 2) p.Line (BasePoint.X + 2, BasePoint.Y + SegHeight - 1)-(BasePoint.X + SegWidth - 2, BasePoint.Y + SegHeight - 1) p.Line (BasePoint.X + 1, BasePoint.Y + SegHeight)-(BasePoint.X + SegWidth - 1, BasePoint.Y + SegHeight) Case 5 p.Line (BasePoint.X, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X, BasePoint.Y + SegHeight) p.Line (BasePoint.X + 1, BasePoint.Y + (SegHeight \ 2) + 1)-(BasePoint.X + 1, BasePoint.Y + SegHeight - 1) p.Line (BasePoint.X + 2, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X + 2, BasePoint.Y + SegHeight - 2) Case 6 p.Line (BasePoint.X, BasePoint.Y + 1)-(BasePoint.X, BasePoint.Y + (SegHeight \ 2) - 1) p.Line (BasePoint.X + 1, BasePoint.Y + 2)-(BasePoint.X + 1, BasePoint.Y + (SegHeight \ 2)) p.Line (BasePoint.X + 2, BasePoint.Y + 3)-(BasePoint.X + 2, BasePoint.Y + (SegHeight \ 2) - 1) Case 7 p.Line (BasePoint.X + 3, BasePoint.Y + (SegHeight \ 2) - 1)-(BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) - 1) p.Line (BasePoint.X + 2, BasePoint.Y + (SegHeight \ 2))-(BasePoint.X + SegWidth - 2, BasePoint.Y + (SegHeight \ 2)) p.Line (BasePoint.X + 3, BasePoint.Y + (SegHeight \ 2) + 1)-(BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) + 1) End Select End Sub Public Property Let Caption(ByVal Value As String) Dim OrigX As Integer OrigX = BasePoint.X p.Cls While Value <> "" If Left$(Value, 1) <> ":" And Left$(Value, 1) <> "." Then DrawNumber (Val(Left$(Value, 1))) BasePoint.X = BasePoint.X + SegWidth + 3 Else If Left$(Value, 1) = "." Then p.Line (BasePoint.X + (SegWidth \ 2) - 4, BasePoint.Y + (SegHeight \ 2) + 6)-(BasePoint.X + (SegWidth \ 2), BasePoint.Y + (SegHeight \ 2) + 9), , BF BasePoint.X = BasePoint.X + SegWidth Else p.Line (BasePoint.X + (SegWidth \ 2) - 4, BasePoint.Y + (SegHeight \ 2) - 6)-(BasePoint.X + (SegWidth \ 2), BasePoint.Y + (SegHeight \ 2) - 3), , BF p.Line (BasePoint.X + (SegWidth \ 2) - 4, BasePoint.Y + (SegHeight \ 2) + 4)-(BasePoint.X + (SegWidth \ 2), BasePoint.Y + (SegHeight \ 2) + 7), , BF BasePoint.X = BasePoint.X + SegWidth End If End If Value = Right$(Value, Len(Value) - 1) Wend BasePoint.X = OrigX End Property Property Let ForeColor(Color As Long) p.ForeColor = Color End Property

Public Sub NewLCD(PBox As PictureBox) Set p = PBox p.ScaleMode = 3 ' pixel p.AutoRedraw = True BasePoint.X = 2 BasePoint.Y = 2 SegHeight = p.ScaleHeight - 6 SegWidth = (SegHeight \ 2) + 2 End Sub ´°ÌåÖÐ£º Option Explicit Dim lcdTest1 As New mcLCD Private Sub Form_Load() lcdTest1.NewLCD picture1 End Sub Private Sub Timer1_Timer() lcdTest1.Caption = Time End Sub 48.½«²¿·Ö²Ëµ¥·ÅÖÃÔÚ´°ÌåµÄ×îÓÒ¶Î£¨Èç°ïÖúµÈ£© ÔÚ²Ëµ¥±à¼Æ÷ÖÐÔÚ´ý·ÅÖÃÓÚ×îÓÒ¶ÎµÄ²Ëµ¥Ç°¼ÓÒ»±êÌâÎª¿Õ¸ñµÄ²Ëµ¥£¬²¢È¥µôvisableÊôÐÔÇ°¹³ºÅ¡£ Private Type MENUITEMINFO '.......Çë×Ô¼º¼ÓÉÏ°¡ End Type Private Const MFT_RIGHTJUSTIFY = &H4000 'APIº¯ÊýÉùÃ÷ Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As _ MENUITEMINFO) As Long Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long 'ÔÚ´°ÌåÔØÈë¹ý³Ì£¨Ò²¿É·ÅÔÚÆäËû¹ý³Ì£©ÖÐ¶Ô²Ëµ¥ÉèÖÃ½øÐÐ¸ü¸Ä Private Sub Form_Load() Dim my_menuItemInfo As MENUITEMINFO Dim return_value As Long my_menuItemInfo.cbSize = 44 my_menuItemInfo.fMask = 16 my_menuItemInfo.cch = 128 my_menuItemInfo.dwTypeData = Space$(128) return_value = GetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo) 'ÕâÀïµÄ2Çë¸ù¾Ý×Ô¼ºµÄÇé¿ö¶ø¶¨£¬ÎªÕý³£ÏÔÊ¾ÔÚ×ó¶ËµÄ²Ëµ¥Êý my_menuItemInfo.fType = MFT_RIGHTJUSTIFY return_value = SetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo) End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 11:50:00

49.ListÃ¿ÐÐÒÔÏàÓ¦µÄÄÚÈÝÎªÌáÊ¾ '----------------------By ³ÂÈñ------------------------------ 'Èç¹ûÄãÒªÔÚInternet»òBBSÉÏ×ªÌùÎÄÕÂ,ÇëÍ¨ÖªÎÒÖªµÀ£¨Ã»ÓÐÍ¨Öª£¬²»ÖªµÀ·¸²»·¸·¨£¬ºÇºÇ£© 'Õâ¸ö³ÌÐòÑÝÊ¾ÈçºÎ¸øList BoxµÄÃ¿¸öÁÐ±íÐÐ¼ÓÉÏ²»Í¬µÄÌáÊ¾ÐÐ 'ÔËÐÐ¸Ã³ÌÐò£¬µ±Êó±êÒÆ¶¯µ½ÈÎÒ»ÐÐÉÏºó£¬µ¯³öµÄToolTip¾Í»áÌáÊ¾¸ÃÐÐµÄÍêÕûÄÚÈÝ 'Option Explicit 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 Const LB_ITEMFROMPOINT = &H1A9 Private Sub Form_Load() With List1 .AddItem "aaa" .AddItem "bbb" .AddItem "ccc" End With End Sub Private Sub List1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) ' present related tip message Dim lXPoint As Long Dim lYPoint As Long Dim lIndex As Long If Button = 0 Then ' Èç¹ûÃ»ÓÐ°´Å¥±»°´ÏÂ lXPoint = CLng(X / Screen.TwipsPerPixelX) lYPoint = CLng(Y / Screen.TwipsPerPixelY) With List1 ' »ñµÃµ±Ç°µÄ¹â±êËùÔÚµÄµÄÆÁÄ»Î»ÖÃÈ·¶¨±êÌâÎ»ÖÃ lIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, _ ByVal ((lYPoint * 65536) + lXPoint)) ' ÏÔÊ¾ÌáÊ¾ÐÐ»òÇå³ýÌáÊ¾ÐÐ If (lIndex >= 0) And (lIndex <= .ListCount) Then .ToolTipText = .List(lIndex) Else .ToolTipText = "" End If End With End If End Sub

50.½«²¿·Ö²Ëµ¥·ÅÖÃÔÚ´°ÌåµÄ×îÓÒ¶Î£¨Èç°ïÖúµÈ£© ÔÚ²Ëµ¥±à¼Æ÷ÖÐÔÚ´ý·ÅÖÃÓÚ×îÓÒ¶ÎµÄ²Ëµ¥Ç°¼ÓÒ»±êÌâÎª¿Õ¸ñµÄ²Ëµ¥£¬²¢È¥µôvisableÊôÐÔÇ°¹³ºÅ¡£ Private Type MENUITEMINFO '.......Çë×Ô¼º¼ÓÉÏ°¡ End Type Private Const MFT_RIGHTJUSTIFY = &H4000 'APIº¯ÊýÉùÃ÷ Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As _ MENUITEMINFO) As Long Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long 'ÔÚ´°ÌåÔØÈë¹ý³Ì£¨Ò²¿É·ÅÔÚÆäËû¹ý³Ì£©ÖÐ¶Ô²Ëµ¥ÉèÖÃ½øÐÐ¸ü¸Ä Private Sub Form_Load() Dim my_menuItemInfo As MENUITEMINFO Dim return_value As Long my_menuItemInfo.cbSize = 44 my_menuItemInfo.fMask = 16 my_menuItemInfo.cch = 128 my_menuItemInfo.dwTypeData = Space$(128) return_value = GetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo) 'ÕâÀïµÄ2Çë¸ù¾Ý×Ô¼ºµÄÇé¿ö¶ø¶¨£¬ÎªÕý³£ÏÔÊ¾ÔÚ×ó¶ËµÄ²Ëµ¥Êý my_menuItemInfo.fType = MFT_RIGHTJUSTIFY return_value = SetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo) End Sub

51. ¸Ä±äÆÁÄ»·Ö±æÂÊ Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long Private Const CCHDEVICENAME = 32 Private Const CCHFORMNAME = 32 Private Const ENUM_CURRENT_SETTINGS = 1 Private Type DEVMODE .........(Çë×Ô¼ºÌí¼ÓÉÏ£© End Type Private Declare Function ChangeDisplaySettings Lib "user32" _ Alias "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwflags As Long) As Long Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _ (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Dim pNewMode As DEVMODE Dim pOldMode As Long Dim nOrgWidth As Integer, nOrgHeight As Integer 'ÉèÖÃÏÔÊ¾Æ÷·Ö±æÂÊµÄÖ´ÐÐº¯Êý Private Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) _ As Long ', Freq As Long) As Long On Error GoTo ErrorHandler Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Const DM_BITSPERPEL = &H40000 Const DM_DISPLAYFLAGS = &H200000 Const DM_DISPLAYFREQUENCY = &H400000 With pNewMode .dmSize = Len(pNewMode) If Color = 0 Then 'Color = 0 Ê±²»¸ü¸ÄÆÁÄ»ÑÕÉ« .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Else .dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT End If .dmPelsWidth = Width .dmPelsHeight = Height If Color <> 0 Then .dmBitsPerPel = Color End If End With pOldMode = lstrcpy(pNewMode, pNewMode) SetDisplayMode = ChangeDisplaySettings(pOldMode, 1) Exit Function ErrorHandler: MsgBox Err.Description End Function Private Sub Command1_Click() Dim nWidth As Integer, nHeight As Integer, nColor As Integer Select Case Combo1.ListIndex Case 0 nWidth = 640: nHeight = 480: nColor = 16 '640*480*16Î»Õæ²ÊÉ«,256É«nColor _ = 8,16É«nColor = 4,nColor = 0 ±íÊ¾²»¸Ä±äÑÕÉ« Case 1 nWidth = 640: nHeight = 480: nColor = 24 Case 2 nWidth = 640: nHeight = 480: nColor = 32 Case 3 nWidth = 800: nHeight = 600: nColor = 16 Case 4 nWidth = 800: nHeight = 600: nColor = 24 Case 5 nWidth = 800: nHeight = 600: nColor = 32 Case 6 nWidth = 1024: nHeight = 768: nColor = 16 Case 7 nWidth = 1024: nHeight = 768: nColor = 24 Case 8 nWidth = 1024: nHeight = 768: nColor = 32 Case other nWidth = 800: nHeight = 600: nColor = 16 End Select Call SetDisplayMode(nWidth, nHeight, nColor) '×¢Òâ,ÏµÍ³²»Ö§³ÖµÄÏÔÊ¾Ä£Ê½²» 'ÄÜÑ¡£¬·ñÔò×¼±¸ÓÃ°²È«Ä£Ê½ÖØÆô¶¯°É. End Sub Private Sub Form_Load() Combo1.AddItem "640*480*16Î»Õæ²ÊÉ«" Combo1.AddItem "640*480*24Î»Õæ²ÊÉ«" Combo1.AddItem "640*480*32Î»Õæ²ÊÉ«" Combo1.AddItem "800*600*16Î»Õæ²ÊÉ«" Combo1.AddItem "800*600*24Î»Õæ²ÊÉ«" Combo1.AddItem "800*600*32Î»Õæ²ÊÉ«" Combo1.AddItem "1024*768*16Î»Õæ²ÊÉ«" Combo1.AddItem "1024*768*24Î»Õæ²ÊÉ«" Combo1.AddItem "1024*768*32Î»Õæ²ÊÉ«" Combo1.Text = Combo1.List(0) nOrgWidth = GetDisplayWidth nOrgHeight = GetDisplayHeight 'nOrgWidth = GetSystemMetrics(SM_CXSCREEN)'Á½ÖÖ»ñÈ¡³õÊ¼ÆÁÄ»´óÐ¡µÄ·½·¨¾ù¿É 'nOrgHeight = GetSystemMetrics(SM_CYSCREEN) End Sub Private Function GetDisplayWidth() As Integer GetDisplayWidth = Screen.Width \ Screen.TwipsPerPixelX End Function Private Function GetDisplayHeight() As Integer GetDisplayHeight = Screen.Height \ Screen.TwipsPerPixelY End Function Private Sub RestoreDisplayMode() Call SetDisplayMode(nOrgWidth, nOrgHeight, 0) End Sub Private Sub Form_Unload(Cancel As Integer) RestoreDisplayMode End Sub 52 .¸÷ÖÖ½øÖÆ×ª»» Function Bin2Dec(InputData As String) As Double '¶þ½øÖÆ×ª±ä³ÉÊ®½øÖÆ Dim DecOut As Double:Dim I As Integer:Dim LenBin As Double:Dim JOne As String LenBin = Len(InputData) 'È·ÈÏÊÇ·ñÎª¶þ½øÖÆÊý For I = 1 To LenBin JOne = Mid(InputData, I, 1) If JOne <> "0" And JOne <> "1" Then MsgBox "NOT A BINARY NUMBER", vbCritical Exit Function End If Next I DecOut = 0 For I = Len(InputData) To 1 Step -1 If Mid(InputData, I, 1) = "1" Then DecOut = DecOut + 2 ^ (Len(InputData) - I) End If Next I Bin2Dec = DecOut End Function

Function Dec2Bin(InputData As Double) As String 'Ê®½øÖÆ×ª±äÎª¶þ½øÖÆ Dim Quot As Double:Dim Remainder As Double:Dim BinOut As String:Dim I As Integer Dim NewVal As Double:Dim TempString As String:Dim TempVal As Double Dim BinTemp As String:Dim BinTemp1 As String:Dim PosDot As Integer Dim Temp2 As String '¼ì²éÊÇ·ñÎªÊ®½øÖÆµÄÐ¡Êýµã If InStr(1, CStr(InputData), ".") Then MsgBox "Only Whole Numbers can be converted", vbCritical GoTo eds End If BinOut = "" NewVal = InputData DoAgain: '¿ªÊ¼¼ÆËã NewVal = (NewVal / 2) 'Èç¹ûÓÐÓàÊý If InStr(1, CStr(NewVal), ".") Then BinOut = BinOut + "1" 'µÃµ½ÓàÊý NewVal = Format(NewVal, "#0") NewVal = (NewVal - 1) If NewVal < 1 Then GoTo DoneIt End If Else BinOut = BinOut + "0" If NewVal < 1 Then GoTo DoneIt End If End If GoTo DoAgain DoneIt: BinTemp = "" 'µßµ¹½á¹û For I = Len(BinOut) To 1 Step -1 BinTemp1 = Mid(BinOut, I, 1) BinTemp = BinTemp + BinTemp1 Next I BinOut = BinTemp 'Êä³ö½á¹û Dec2Bin = BinOut eds: End Function

Function Bin2Hex(InputData As String) As String '¶þ½øÖÆ×ª±ä³ÉÊ®Áù½øÖÆ Dim I As Integer:Dim LenBin As Integer:Dim JOne As String:Dim NumBlocks As Integer Dim FullBin As String:Dim HexOut As String:Dim TempBinBlock As String Dim TempHex As String LenBin = Len(InputData)'È·ÈÏÊÇ·ñÎª¶þ½øÖÆÊý For I = 1 To LenBin JOne = Mid(InputData, I, 1) If JOne <> "0" And JOne <> "1" Then MsgBox "NOT A BINARY NUMBER", vbCritical Exit Function End If Next I 'ÉèÖÃ¶þ½øÖÆ±äÁ¿ FullBin = InputData ' Èç¹ûÕâ¸öÖµµÄ³¤¶ÈÐ¡ÓÚ4,Ôò²¹0 If LenBin < 4 Then If LenBin = 3 Then FullBin = "0" + FullBin ElseIf LenBin = 2 Then FullBin = "00" + FullBin ElseIf LenBin = 1 Then FullBin = "000" + FullBin ElseIf LenBin = 0 Then MsgBox "Nothing Given..", vbCritical Exit Function End If NumBlocks = 1 GoTo DoBlocks End If If LenBin = 4 Then NumBlocks = 1 GoTo DoBlocks End If If LenBin > 4 Then Dim TempHold As Currency Dim TempDiv As Currency Dim AfterDot As Integer Dim Pos As Integer TempHold = Len(InputData) TempDiv = (TempHold / 4) Pos = InStr(1, CStr(TempDiv), ".") If Pos = 0 Then NumBlocks = TempDiv GoTo DoBlocks End If AfterDot = Mid(CStr(TempDiv), (Pos + 1)) If AfterDot = 25 Then FullBin = "000" + FullBin NumBlocks = (Len(FullBin) / 4) ElseIf AfterDot = 5 Then FullBin = "00" + FullBin NumBlocks = (Len(FullBin) / 4) ElseIf AfterDot = 75 Then FullBin = "0" + FullBin NumBlocks = (Len(FullBin) / 4) Else MsgBox "Big Time Screw up happened, WAHHHHHHHHHHH", vbInformation Exit Function End If GoTo DoBlocks End If DoBlocks: HexOut = "" For I = 1 To Len(FullBin) Step 4 TempBinBlock = Mid(FullBin, I, 4) If TempBinBlock = "0000" Then HexOut = HexOut + "0" ElseIf TempBinBlock = "0001" Then HexOut = HexOut + "1" ElseIf TempBinBlock = "0010" Then HexOut = HexOut + "2" ElseIf TempBinBlock = "0011" Then HexOut = HexOut + "3" ElseIf TempBinBlock = "0100" Then HexOut = HexOut + "4" ElseIf TempBinBlock = "0101" Then HexOut = HexOut + "5" ElseIf TempBinBlock = "0110" Then HexOut = HexOut + "6" ElseIf TempBinBlock = "0111" Then HexOut = HexOut + "7" ElseIf TempBinBlock = "1000" Then HexOut = HexOut + "8" ElseIf TempBinBlock = "1001" Then HexOut = HexOut + "9" ElseIf TempBinBlock = "1010" Then HexOut = HexOut + "A" ElseIf TempBinBlock = "1011" Then HexOut = HexOut + "B" ElseIf TempBinBlock = "1100" Then HexOut = HexOut + "C" ElseIf TempBinBlock = "1101" Then HexOut = HexOut + "D" ElseIf TempBinBlock = "1110" Then HexOut = HexOut + "E" ElseIf TempBinBlock = "1111" Then HexOut = HexOut + "F" End If Next I Bin2Hex = HexOut eds: End Function

Function Hex2Bin(InputData As String) As String Dim I As Integer:Dim BinOut As String:Dim Lenhex As Integer InputData = UCase(InputData) Lenhex = Len(InputData) For I = 1 To Lenhex If IsNumeric(Mid(InputData, I, 1)) Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "A" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "B" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "C" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "D" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "E" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "F" Then GoTo NumOk Else MsgBox "Number given is not in Hex format", vbCritical Exit Function End If NumOk: Next I BinOut = "" For I = 1 To Lenhex If Mid(InputData, I, 1) = "0" Then BinOut = BinOut + "0000" ElseIf Mid(InputData, I, 1) = "1" Then BinOut = BinOut + "0001" ElseIf Mid(InputData, I, 1) = "2" Then BinOut = BinOut + "0010" ElseIf Mid(InputData, I, 1) = "3" Then BinOut = BinOut + "0011" ElseIf Mid(InputData, I, 1) = "4" Then BinOut = BinOut + "0100" ElseIf Mid(InputData, I, 1) = "5" Then BinOut = BinOut + "0101" ElseIf Mid(InputData, I, 1) = "6" Then BinOut = BinOut + "0110" ElseIf Mid(InputData, I, 1) = "7" Then BinOut = BinOut + "0111" ElseIf Mid(InputData, I, 1) = "8" Then BinOut = BinOut + "1000" ElseIf Mid(InputData, I, 1) = "9" Then BinOut = BinOut + "1001" ElseIf Mid(InputData, I, 1) = "A" Then BinOut = BinOut + "1010" ElseIf Mid(InputData, I, 1) = "B" Then BinOut = BinOut + "1011" ElseIf Mid(InputData, I, 1) = "C" Then BinOut = BinOut + "1100" ElseIf Mid(InputData, I, 1) = "D" Then BinOut = BinOut + "1101" ElseIf Mid(InputData, I, 1) = "E" Then BinOut = BinOut + "1110" ElseIf Mid(InputData, I, 1) = "F" Then BinOut = BinOut + "1111" Else MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical End If Next I Hex2Bin = BinOut eds: End Function Function Hex2Dec(InputData As String) As Double Dim I As Integer:Dim DecOut As Double:Dim Lenhex As Integer:Dim HexStep As Double DecOut = 0 InputData = UCase(InputData) Lenhex = Len(InputData) For I = 1 To Lenhex If IsNumeric(Mid(InputData, I, 1)) Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "A" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "B" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "C" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "D" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "E" Then GoTo NumOk ElseIf Mid(InputData, I, 1) = "F" Then GoTo NumOk Else MsgBox "Number given is not in Hex format", vbCritical Exit Function End If NumOk: Next I HexStep = 0 For I = Lenhex To 1 Step -1 HexStep = HexStep * 16 If HexStep = 0 Then HexStep = 1 End If If Mid(InputData, I, 1) = "0" Then DecOut = DecOut + (0 * HexStep) ElseIf Mid(InputData, I, 1) = "1" Then DecOut = DecOut + (1 * HexStep) ElseIf Mid(InputData, I, 1) = "2" Then DecOut = DecOut + (2 * HexStep) ElseIf Mid(InputData, I, 1) = "3" Then DecOut = DecOut + (3 * HexStep) ElseIf Mid(InputData, I, 1) = "4" Then DecOut = DecOut + (4 * HexStep) ElseIf Mid(InputData, I, 1) = "5" Then DecOut = DecOut + (5 * HexStep) ElseIf Mid(InputData, I, 1) = "6" Then DecOut = DecOut + (6 * HexStep) ElseIf Mid(InputData, I, 1) = "7" Then DecOut = DecOut + (7 * HexStep) ElseIf Mid(InputData, I, 1) = "8" Then DecOut = DecOut + (8 * HexStep) ElseIf Mid(InputData, I, 1) = "9" Then DecOut = DecOut + (9 * HexStep) ElseIf Mid(InputData, I, 1) = "A" Then DecOut = DecOut + (10 * HexStep) ElseIf Mid(InputData, I, 1) = "B" Then DecOut = DecOut + (11 * HexStep) ElseIf Mid(InputData, I, 1) = "C" Then DecOut = DecOut + (12 * HexStep) ElseIf Mid(InputData, I, 1) = "D" Then DecOut = DecOut + (13 * HexStep) ElseIf Mid(InputData, I, 1) = "E" Then DecOut = DecOut + (14 * HexStep) ElseIf Mid(InputData, I, 1) = "F" Then DecOut = DecOut + (15 * HexStep) Else MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical End If Next I Hex2Dec = DecOut eds: End Function µ÷ÓÃ·½Ê½£º Private Sub cmdbin2hex_Click() txthex.Text = Bin2Hex(txtbinary.Text) End Sub Private Sub cmddec2bin_Click() If IsNumeric(txtdec2bin.Text) Then txtdec2bin2.Text = Dec2Bin(txtdec2bin.Text) End If End Sub Private Sub cmdDecHex_Click() If IsNumeric(txtDecimal.Text) Then txtdechex.Text = Hex(CDbl(txtDecimal.Text)) Else MsgBox "Not a Number.", vbCritical End If End Sub Private Sub cmdhex2bin_Click() txtbinary2.Text = Hex2Bin(txthex2.Text) End Sub Private Sub cmdhexdec_Click() txtdec2.Text = CStr(Hex2Dec(txthexdec.Text)) End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 11:53:00

53. ¿ØÖÆ×óÓÒÉùµÀ Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal _ lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As _ Long, ByVal hwndCallback As Long) As Long Private Sub Command1_Click() PlaySound "F:\music\incubus\Ë®Ä¾Äê»ª-ÔÙ¼ûÁË×î°®µÄÈË.mp3" End Sub Function PlaySound(ByVal FileName As String) As Boolean Dim cmd As String, exName As String exName = Right(FileName, 3) mciSendString "close " & exName, 0, 0, 0 cmd = "open " & FileName & " alias " & exName mciSendString cmd, 0, 0, 0 PlaySound = mciSendString("play " & exName, 0, 0, 0) End Function Private Sub Command2_Click() Static flag As Boolean ' ÉèÖÃ×óÉùµÀ¿ª¹Ø mciSendString "set all audio all " & IIf(flag, "on", "off"), 0, 0, 0 If flag = False Then Command2.Caption = "×óÉùµÀ(¹Ø)" Else Command2.Caption = "×óÉùµÀ(¿ª)" End If flag = Not flag End Sub Private Sub Command3_Click() Static flag As Boolean ' ÉèÖÃÓÒÉùµÀ¿ª¹Ø mciSendString "set all audio all " & IIf(flag, "on", "off"), 0, 0, 0 If flag = False Then Command3.Caption = "ÓÒÉùµÀ(¹Ø)" Else Command3.Caption = "ÓÒÉùµÀ(¿ª)" End If flag = Not flag End Sub Private Sub Command4_Click() '' ÉèÖÃmp3Éè±¸ÒôÁ¿:0--1000,500±íÊ¾ÒôÁ¿ÊÊÖÐ mciSendString "set mp3 audio volume to 500", 0, 0, 0 End Sub 54.ÀûÓÃVB²úÉúÆÁÄ»±ä°µµÄÐ§¹û(×ª£¬±ðÈËµÄ´úÂë£© Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long

Private bybits(1 To 16) As Byte Private hBitmap As Long, hBrush As Long Private hDesktopWnd As Long

Private Sub Command1_Click() Dim rop As Long, res As Long Dim hdc5 As Long, width5 As Long, height5 As Long

hdc5 = GetDC(0) width5 = Screen.Width \ Screen.TwipsPerPixelX height5 = Screen.Height \ Screen.TwipsPerPixelY

rop = &HA000C9 Call SelectObject(hdc5, hBrush) res = PatBlt(hdc5, 0, 0, width5, height5, rop) Call DeleteObject(hBrush)

res = ReleaseDC(0, hdc5) End Sub

Private Sub Command2_Click() Dim aa As Long

 aa = InvalidateRect(0, 0, 1) End Sub

Private Sub Form_Load() Dim ary Dim i As Long ary = Array(&H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0) For i = 1 To 16 bybits(i) = ary(i - 1) Next i hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1)) hBrush = CreatePatternBrush(hBitmap) Picture1.ForeColor = RGB(0, 0, 0) Picture1.BackColor = RGB(255, 255, 255) Picture1.ScaleMode = 3 End Sub 55.ÏÞ¶¨Êó±êÔÚÄ³Ò»ÇøÓòÄÚ Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long Declare Function SetCursorPos Lib "user32" (ByVal x As Long, _ ByVal y As Long) As Long Declare Function GetWindowRect Lib "user32" _ (ByVal hwnd As Long, lpRect As RECT) As Long 'Éè¶¨Mouse¿ÉÒÆ¶¯µÄÎ§ÊÇÔÚÄ³¸öcontrolÏîÖ®ÄÚ Public Function toLockCursor(ByVal ctlHwnd As Long) As Boolean Dim rect5 As RECT Dim res As Long GetWindowRect ctlHwnd, rect5 'È¡µÃwindowµÄËÄ¸ö½Ç SetCursorPos (rect5.Top + rect5.Bottom) \ 2, (rect5.Left + rect5.Right) \ 2 res = ClipCursor(rect5) If res = 1 Then toLockCursor = True Else toLockCursor = False End If End Function 'Éè¶¨MouseÒÆ¶¯µÄÎ§Îª¸öÓ©Ä» Public Sub toUnLockCursor() Dim rscreen As RECT rscreen.Top = 0 rscreen.Left = 0 rscreen.Right = Screen.Width \ Screen.TwipsPerPixelX rscreen.Bottom = Screen.Height \ Screen.TwipsPerPixelY ClipCursor rscreen End Sub

Private Sub Command1_Click() Call toLockCursor(Me.hwnd) '°ÑMe.hwnd¸ÄÎªÆäËû¿Ø¼þµÄ¾ä±ú£¬ÔòÊó±ê¾ÍÏÞÖÆÔÚÕâ¸öÇøÓòÀï¡£ End Sub Private Sub Command2_Click() Call toUnLockCursor End Sub

56.»ñµÃÆÁÄ»·Ö±æÂÊ ·½·¨Ò»£º Debug.Print Screen.Width / Screen.TwipsPerPixelX Debug.Print Screen.Height / Screen.TwipsPerPixelY ·½·¨¶þ£º Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Public Sub DeviceInfo(DisplayX As Integer, DisplayY As Integer, DisplayColor As Integer) Dim hdesktopwnd Dim hdccaps Dim lblRes As String Dim DisplayBits Dim DisplayPlanes Dim RetVal hdccaps = GetDC(hdesktopwnd) DisplayBits = GetDeviceCaps(hdccaps, 12) DisplayPlanes = GetDeviceCaps(hdccaps, 14) DisplayX = GetDeviceCaps(hdccaps, 8) DisplayY = GetDeviceCaps(hdccaps, 10) RetVal = ReleaseDC(hdesktopwnd, hdccaps) Select Case DisplayBits Case 1 If DisplayPlanes = 1 Then DisplayColor = 1 Else If DisplayPlanes = 4 Then DisplayColor = 4 Else DisplayColor = 0 End If Case 8 DisplayColor = 8 Case 16 DisplayColor = 16 Case 24 DisplayColor = 24 Case 32 DisplayColor = 32 Case Else DisplayColor = 0 'Î´ÖªÉ«²Ê¶È End Select End Sub

Private Sub Command1_Click() Dim x As Integer, y As Integer, color As Integer DeviceInfo x, y, color MsgBox "·Ö±æÂÊÎª " & x & "x" & y End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 11:54:00

57.¶¯Ì¬Ìí¼Ó²Ëµ¥ Const MF_CHECKED = &H8& Const MF_APPEND = &H100& Const TPM_LEFTALIGN = &H0& Const MF_DISABLED = &H2& Const MF_GRAYED = &H1& Const MF_SEPARATOR = &H800& Const MF_STRING = &H0& Const TPM_RETURNCMD = &H100& Const TPM_RIGHTBUTTON = &H2& Private Type POINTAPI x As Long y As Long End Type Private Declare Function CreatePopupMenu Lib "user32" () As Long Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal HWnd As Long, ByVal lptpm As Any) As Long Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Dim hMenu As Long Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 2 Then Dim Pt As POINTAPI Dim ret As Long hMenu = CreatePopupMenu() AppendMenu hMenu, MF_STRING, 1, "Hello !" AppendMenu hMenu, MF_GRAYED Or MF_DISABLED, 2, "Testing ..." AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0& AppendMenu hMenu, MF_CHECKED, 4, "TrackPopupMenu" GetCursorPos Pt ret = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, Pt.x, Pt.y, Me.HWnd, ByVal 0&) DestroyMenu hMenu Select Case ret Case 1 MsgBox "Hello !" Case 4 MsgBox "TrackPopupMenu" End Select End If End Sub 58.ÀûÓÃAPIº¯ÊýÊµÏÖ¶¨Ê±Æ÷¹¦ÄÜ Ä£¿éÖÐ£º Option Explicit Public lTimerId As Long Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long Private Sub TimerProc(ByVal lHwnd As Long, ByVal lMsg As Long, ByVal lTimerId As Long, ByVal lTime As Long) Static i As Long Form1.Label1.Caption = i i = i + 1 End Sub Public Sub StartTimer(lMinute As Long) lTimerId = SetTimer(0, 0, lMinute, AddressOf TimerProc) End Sub Public Function StopTimer(lTimerId As Long) As Long StopTimer = KillTimer(0, lTimerId) End Function

´°ÌåÖÐ£º Private Sub Form_Load() StartTimer 1000 End Sub

Private Sub Form_Unload(Cancel As Integer) StopTimer lTimerId End Sub 59.´´½¨GUID

'GUIDÊÇGlobally Unique IDentifierµÄËõÐ´.ÓÉÒ»¸öÌØÊâµÄËã·¨À´²úÉúÕâÐ©128Î»µÄÊý,²¢±£Ö¤²»²úÉúÖØ¸´µÄGUID¡ªÖØ¸´µÄ¿ÉÄÜÐÔµ±È»´æÔÚ,µ«ÓÐÌ«¶à¿ÉÓÃµÄÊýÁË,Òò´ËËã·¨ÌØ±ð·ÀÖ¹²úÉúÖØ¸´µÄÊý,ÕâÖÖÇé¿öÄãÒ»Éú¶¼²»»á¿´µ½. ActiveX¿Ø¼þ¶¼ÓÐÒ»¸öÓÃÓÚÏà»¥Çø±ðµÄGUID.ÄãÈçºÎÔÚ×Ô¼ºµÄ³ÌÐòÖÐÊ¹ÓÃGUIDÄØ? ÀýÈç,µ±Ò»¸öÊý¾Ý¿âµÄÃ¿¸öÌõÄ¿¶¼ÐèÒªÓÉÒ»¸öÎ¨Ò»µÄ¼üÖµÊ±.ÏÂÃæµÄ´úÂë½«¸øÄãÒ»¸ö´ð°¸:

Option Explicit Private Type GUID Data1 As Long Data2 As Long Data3 As Long Data4(8) As Byte End Type Private Declare Function CoCreateGuid Lib "ole32.dll" (pguid As GUID) As Long Private Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Long) As Long Private Function GUIDGen() As String Dim uGUID As GUID Dim sGUID As String Dim bGUID() As Byte Dim lLen As Long Dim RetVal As Long lLen = 40 bGUID = String(lLen, 0) CoCreateGuid uGUID '°Ñ½á¹¹×ª»»ÎªÒ»¸ö¿ÉÏÔÊ¾µÄ×Ö·û´® RetVal = StringFromGUID2(uGUID, VarPtr(bGUID(0)), lLen) sGUID = bGUID If (Asc(Mid$(sGUID, RetVal, 1)) = 0) Then RetVal = RetVal - 1 GUIDGen = Left$(sGUID, RetVal) End Function Private Sub cmdGUID_Click() txtGUID.Text = GUIDGen End Sub

60.´´½¨½¥±ä´°Ìå Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Type RECT left As Long top As Long right As Long bottom As Long End Type Private Sub Form_Paint() Dim Color As Long Dim hBrush As Long Dim OldMode As Long Dim RetVal As Long Dim StepSize As Long Dim X As Long Dim FillArea As RECT OldMode = Me.ScaleMode Me.ScaleMode = 3 StepSize = 1 + Me.ScaleHeight / 80 Color = 255 FillArea.left = 0 FillArea.right = Me.ScaleWidth FillArea.top = 0 FillArea.bottom = StepSize For X = 1 To 80 hBrush = CreateSolidBrush(RGB(Color / 2, Color * 2, Color)) RetVal = FillRect(Me.hdc, FillArea, hBrush) RetVal = DeleteObject(hBrush) Color = Color - 2 If Color < 0 Then Color = 0 FillArea.top = FillArea.bottom FillArea.bottom = FillArea.bottom + StepSize Next Me.ScaleMode = OldMode End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 11:56:00

61.½ûÖ¹ÆÁÄ»±£»¤ Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long Const SPI_SETSCREENSAVEACTIVE = 17 Const SPIF_SENDWININICHANGE = &H2 Const SPIF_UPDATEINIFILE = &H1

Private Sub Form_Load() SystemParametersInfo SPI_SETSCREENSAVEACTIVE, 0, 0, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE End Sub

62.ÀàËÆQQ½çÃæµÄ°´Å¥¡£ commandÒÔpictureboxÎªÈÝÆ÷¡£ Private Sub Form_Load() Me.WindowState = 2 With Picture1 .Width = 1200 + 60 .Height = 4860 End With Dim i As Integer For i = Command1.Count - 1 To 0 Step -1 With Command1(i) .Width = 1200 .Height = 300 .Top = Picture1.ScaleHeight - 300 * (Command1.Count - i) .Left = 0 .Caption = "·Ö×é " & i + 1 End With Next i Command1(0).Top = 0 End Sub

Private Sub Command1_Click(Index As Integer) Picture1.SetFocus '°Ñ½¹µã¸øPicture1ÊÇÎªÁË²»ÈÃ°´Å¥³öÏÖÄÑ¿´µÄºÚ¿ò Dim i As Integer For i = 1 To Index Command1(i).Top = 300 * i Next i For i = Command1.Count - 1 To Index + 1 Step -1 Command1(i).Top = Picture1.ScaleHeight - 300 * (Command1.Count - i) Next i End Sub

63.alpha blend Private Declare Function AlphaBlend Lib "msimg32" ( ByVal hDestDC As Long, _ ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, _ ByVal heightSrc As Long, ByVal dreamAKA As Long) As Long 'only Windows 98 or Latter Dim Num As Byte, nN%, nBlend& Private Sub Run_Blending() Num = 255 nN = 5 Do DoEvents nBlend = vbBlue - CLng(Num) * (vbYellow + 1) Num = Num - nN If Num = 0 Then nN = -5 ElseIf Num = 255 Then nN = 5 End If Me.Cls AlphaBlend Me.hDC, 0, 0, picSrc.ScaleWidth, picSrc.ScaleHeight, picSrc.hDC, 0, 0, picSrc.ScaleWidth, picSrc.ScaleHeight, nBlend Loop End Sub Private Sub Form_Activate() Call Run_Blending End Sub Private Sub Form_Unload(Cancel As Integer) End ' STOP Do Loop End Sub

64.¼òµ¥±´Èü¶ûÇúÏß»æÖÆ Option Explicit Private Type POINTAPI x As Long y As Long End Type

Private Declare Function PolyBezier Lib "gdi32" _ (ByVal hdc As Long, _ lppt As POINTAPI, _ ByVal cpoints As Long) As Long

Dim Points(0 To 3) As POINTAPI Dim oldPoint As POINTAPI Dim Index As Integer Private Sub form_load() Caption = "»æÖÆ±´Èû¶ûÇúÏß" ScaleMode = 3 End Sub

Private Sub form_mousedown(button As Integer, _ shift As Integer, x As Single, y As Single) Points(Index).x = x: Points(Index).y = y If Index = 0 Then Cls Else Line (oldPoint.x, oldPoint.y)-(x, y) '»æÖÆÌØÕ÷¶à±ßÐÎ End If oldPoint.x = x: oldPoint.y = y Circle (x, y), 3, vbBlue If Index = 3 Then Form1.ForeColor = vbRed PolyBezier Me.hdc, Points(0), 4 '»æÖÆ±´Èü¶ûÇúÏß Index = 0 Else Index = Index + 1 End If End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 11:59:00

65.¶ÁÐ´INIÎÄ¼þÄ£¿é

Option Explicit '¶ÁÐ´INIÎÄ¼þÄ£¿é Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName As String, ByVal KeyName As String, ByVal keydefault As String, ByVal Filename As String) As Long

Public Function myReadINI(iniFileName, iniSection, iniKey, iniDefault) '¸Ãº¯ÊýµÄÊ¹ÓÃÓë¶Á×¢²á±íÀàËÆ 'inifilenameÎªINIÎÄ¼þÃû£¬inisectionÎªINIÎÄ¼þÖÐµÄÏîÄ¿£¬inikeyÎªÏîÄ¿ÏÂµÄ¼üÃû³Æ£¬inidefaultÎªÄ¬ÈÏ¼üÖµ 'If no section (appname), default is first appname '£¨ÈôÎÞÏîÄ¿Ãû£¬Ä¬ÈÏÎª³õÊ¼Ãû³Æ£© 'if no key, default is first key '£¨ÈôÎÞ¼üÃû£¬Ä¬ÈÏÎª³õÊ¼¼üÃû£© Dim lpApplicationName As String Dim lpKeyName As String Dim lpDefault As String Dim lpReturnedString As String Dim nSize As Long Dim lpFileName As String Dim retval As Long Dim Filename As String 'ÅÐ¶ÏINIÎÄ¼þÊÇ·ñ´æÔÚ If Dir(iniFileName) <> "" Then lpDefault = Space$(254) lpDefault = iniDefault lpReturnedString = Space$(254) nSize = 254 lpFileName = iniFileName lpApplicationName = iniSection lpKeyName = iniKey Filename = lpFileName retval = GetPrivateProfileString(lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName) myReadINI = lpReturnedString End If End Function

Public Function myWriteINI(iniFileName As String, iniSection As String, iniKey As String, Info As String) As String '¸Ãº¯ÊýµÄÊ¹ÓÃÓëÐ´×¢²á±íÀàËÆ£¬¿ÉÔÚINIÎÄ¼þÖÐÌí¼Ó»òÐÞ¸ÄÏî¡¢¼ü¡¢Öµ 'iniFileNameÎªINIÎÄ¼þÃû£¬inisectionÎªINIÎÄ¼þÖÐµÄÏîÄ¿£¬inikeyÎªÏîÄ¿ÏÂµÄ¼üÃû³Æ£¬InfoÎª¼üÖµ Dim retval As Long retval = WritePrivateProfileString(iniSection, iniKey, Info, iniFileName) myWriteINI = LTrim$(Str$(retval)) End Function

Public Sub DelSectionINI(iniFileName As String, iniSection As String) '¸Ã¹ý³Ì¿ÉÉ¾³ýINIÎÄ¼þÖÐÖ¸¶¨µÄÏî 'iniFileNameÎªINIÎÄ¼þÃû£¬iniSectionÎªÖ¸¶¨µÄÏî 'ÅÐ¶ÏINIÎÄ¼þÊÇ·ñ´æÔÚ If Dir(iniFileName) <> "" Then WritePrivateProfileString iniSection, vbNullString, vbNullString, iniFileName End If End Sub

Public Sub DelKeyINI(iniFileName As String, iniSection As String, iniKey As String) '¸Ã¹ý³Ì¿ÉÉ¾³ýINIÎÄ¼þÖÐÖ¸¶¨µÄ¼ü 'iniFileNameÎªINIÎÄ¼þÃû£¬iniSectionÎªÖ¸¶¨µÄÏî£¬iniKeyÎªÖ¸¶¨µÄ¼ü 'ÅÐ¶ÏINIÎÄ¼þÊÇ·ñ´æÔÚ If Dir(iniFileName) <> "" Then WritePrivateProfileString iniSection, iniKey, vbNullString, iniFileName End If End Sub

Public Sub DelValueINI(iniFileName As String, iniSection As String, iniKey As String) '¸Ã¹ý³Ì¿ÉÉ¾³ýINIÎÄ¼þÖÐÖ¸¶¨¼üµÄÖµ 'iniFileNameÎªINIÎÄ¼þÃû£¬iniSectionÎªÖ¸¶¨µÄÏî£¬iniKeyÎªÖ¸¶¨µÄ¼ü 'ÅÐ¶ÏINIÎÄ¼þÊÇ·ñ´æÔÚ If Dir(iniFileName) <> "" Then WritePrivateProfileString iniSection, iniKey, "", iniFileName End If End Sub

Public Sub DelFileINI(iniFileName As String) '¸Ã¹ý³Ì¿ÉÉ¾³ýINIÎÄ¼þ 'iniFileNameÎªINIÎÄ¼þÃû 'ÅÐ¶ÏINIÎÄ¼þÊÇ·ñ´æÔÚ If Dir(iniFileName) <> "" Then Kill iniFileName End If End Sub 66.ÏÔÊ¾ä¯ÀÀÎÄ¼þ¼Ð¶Ô»°¿ò

Option Explicit 'ÏÔÊ¾ä¯ÀÀÎÄ¼þ¼Ð¶Ô»°¿ò ' µ÷ÓÃ·½Ê½:: string = BrowseForFolders(Hwnd,TitleOfDialog) ' ÀýÈç:String1 = BrowseForFolders(Hwnd, "Select target folder...") Public Type BrowseInfo hwndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Public Const BIF_RETURNONLYFSDIRS = 1 Public Const MAX_PATH = 260 Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String Dim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo '³õÊ¼»¯±äÁ¿ With udtBI .hwndOwner = hwndOwner .lpszTitle = lstrcat(sPrompt, "") .ulFlags = BIF_RETURNONLYFSDIRS End With 'µ÷ÓÃ API lpIDList = SHBrowseForFolder(udtBI) If lpIDList Then sPath = String$(MAX_PATH, 0) lResult = SHGetPathFromIDList(lpIDList, sPath) Call CoTaskMemFree(lpIDList) iNull = InStr(sPath, vbNullChar) If iNull Then sPath = Left$(sPath, iNull - 1) End If 'Èç¹ûÑ¡ÔñÈ¡Ïû, sPath = "" BrowseForFolder = sPath End Function 67.×¢²á±í¶ÁÐ´Ä£¿é

Option Explicit '×¢²á±í¶ÁÐ´Ä£¿é 'This program needs 3 buttons Public Const REG_DWORD = 4 Const ERROR_SUCCESS = 0& Const KEY_ALL_ACCESS = &H3F Public Const REG_SZ = 1 ' Unicode nul terminated string Public Const REG_BINARY = 3 ' Free form binary Public Const HKEY_CURRENT_USER = &H80000001 Public Const HKEY_LOCAL_MACHINE = &H80000002 Public Const REG1_KEY = "software\microsoft\windows\currentversion\run" Public Const REG2_KEY = "software\microsoft\windows\currentversion\RunServices"

Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Public 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 Long Public Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long 'retrieve nformation about the key lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize) If lResult = 0 Then If lValueType = REG_SZ Then 'Create a buffer strBuf = String(lDataBufSize, Chr$(0)) 'retrieve the key's content lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize) If lResult = 0 Then 'Remove the unnecessary chr$(0)'s RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1) End If ElseIf lValueType = REG_BINARY Then Dim strData As Integer 'retrieve the key's value lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize) If lResult = 0 Then RegQueryStringValue = strData End If End If End If End Function Public Function GetString(hKey As Long, strPath As String, strValue As String) Dim Ret 'Open the key RegOpenKey hKey, strPath, Ret 'Get the key's content GetString = RegQueryStringValue(Ret, strValue) 'Close the key RegCloseKey Ret End Function Public Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Save a string to the key RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, Len(strData) 'close the key RegCloseKey Ret End Sub Public Sub SaveStringLong(hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Set the key's value RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(strData), 4 'close the key RegCloseKey Ret End Sub Public Sub DelSetting(hKey As Long, strPath As String, strValue As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Delete the key's value RegDeleteValue Ret, strValue 'close the key RegCloseKey Ret End Sub Public Sub SaveRegDWORD(hKey As Long, strPath As String, strValueName As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Save a DWORD to the key RegSetValueEx Ret, strValueName, 0, REG_DWORD, CByte(strData), 4 'close the key RegCloseKey Ret

End Sub 68.API´òÔì¸¡¶¯°´Å¥

Option Base 1 Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Public Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long '--------------------------------------------------------------------------------------------GDIÏà¹Øº¯Êý Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '-------------------------------------------------------------------------------------------- Public Const TME_LEAVE = &H2& Public Const ODS_SELECTED = &H1 Public Const ODT_BUTTON = 4 Public Const WM_DRAWITEM = &H2B Public Const WM_MEASUREITEM = &H2C Public Const IMAGE_BITMAP = 0 Public Const LR_LOADFROMFILE = &H10 Public Const BS_OWNERDRAW = &HB& Public Const GWL_WNDPROC = (-4) Public Const WM_MOUSEMOVE = &H200 Public Const WM_MOUSELEAVE = &H2A3 Public Const WM_LBUTTONUP = &H202 Public Const WS_CHILD = &H40000000 Public Const WS_VISIBLE = &H10000000 Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source '-------------------------ÒÔÏÂÊÇ×Ô¶¨Òå°´Å¥×´Ì¬³£Êý Public Const Leave = 1 'Àë¿ª°´Å¥·¶Î§ Public Const Click = 2 ' °´ÏÂ°´Å¥ Public Const Undo = 3 'ËÉ¿ª°´Å¥ Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Type DRAWITEMSTRUCT '×Ô»æ¿Ø¼þµÄ»æÍ¼½á¹¹£¬ÁíÍâÓÉÓÚËüÔÚWIN32ÀïÃæÊÇÎ¨Ò»µÄ½á¹¹£¬ËùÒÔÔÚVBÀïÃæÒªÓÃµ½CopyMemoryÕâ¸öAPIº¯ÊýÖ±½ÓÖ¸ÏòËüµÄµØÖ· CtlType As Long CtlID As Long ItemID As Long itemAction As Long itemState As Long hwndItem As Long hdc As Long rcItem As RECT itemData As Long End Type Public Type MEASUREITEMSTRUCT '×Ô»æÊ±ºòÉèÖÃ¿Ø¼þµÄ´óÐ¡'Í¬ÉÏ CtlType As Long CtlID As Long ItemID As Long itemWidth As Long itemHeight As Long itemData As Long End Type Public Type TRACKMOUSEEVENTTYPE cbSize As Long dwFlags As Long hwndTrack As Long dwHoverTime As Long End Type Public ImageHandle(3) As Long Public OldMainProc As Long Public OldButtonProc As Long Public CmdHwnd As Long Public MouseLeave As Boolean Public Sub Initialize() '³õÊ¼»¯ LoadPic MouseLeave = True MainProc CreateOwnerDrawButton ButtonProc End Sub Public Sub MainProc() '´°¿Ú×ÔÀà»¯£¨NewMainProc) OldMainProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf NewMainProc) End Sub Public Sub ButtonProc() '°´Å¥×ÔÀà»¯(NewButtonProc) OldButtonProc = SetWindowLong(CmdHwnd, GWL_WNDPROC, AddressOf NewButtonProc) End Sub Public Sub CreateOwnerDrawButton() '´´ÔìÒ»¸ö×Ô»æ°´Å¥ CmdHwnd = CreateWindowEx(0, "Button", "", WS_CHILD Or BS_OWNERDRAW Or WS_VISIBLE, 50, 60, 70, 25, Form1.hwnd, 0, App.hInstance, 0) Dim dc As Long dc = GetDC(CmdHwnd) drawPic Leave

End Sub Public Function NewMainProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '´¦ÀíÖ÷´°¿ÚÏûÏ¢ Select Case Msg Case WM_DRAWITEM OnDrawItem lParam Exit Function Case WM_MEASUREITEM OnMeasureItem lParam End Select NewMainProc = CallWindowProc(OldMainProc, hwnd, Msg, wParam, lParam) End Function Public Function NewButtonProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '´¦Àí°´Å¥ÏûÏ¢ Select Case Msg Case WM_MOUSELEAVE Button_MouseLeave MouseLeave = True Case WM_MOUSEMOVE Button_MouseMove Case WM_LBUTTONUP Button_MouseLButtonUp End Select NewButtonProc = CallWindowProc(OldButtonProc, hwnd, Msg, wParam, lParam) End Function Public Sub Button_MouseMove() 'Êó±êÒÆ¶¯ÊÂ¼þ drawPic Undo If MouseLeave = True Then MouseLeave = False Dim MouseTrack As TRACKMOUSEEVENTTYPE With MouseTrack .cbSize = Len(MouseTrack) .dwFlags = TME_LEAVE .hwndTrack = CmdHwnd End With TrackMouseEvent MouseTrack End If End Sub Public Sub Button_MouseLButtonUp() '×ó¼ü°´ÏÂÊÂ¼þ Debug.Print "ÒÑ°´ÏÂ×ó¼ü" End Sub Public Sub Button_MouseLeave() 'Àë¿ªÊÂ¼þ drawPic Leave Debug.Print "ÒÑÀë¿ª°´Å¥µÄ·¶Î§" End Sub Public Sub OnMeasureItem(lParam As Long) 'ÉèÖÃµÄ´óÐ¡ Dim lpMIS As MEASUREITEMSTRUCT CopyMemory lpMIS, ByVal lParam, Len(lpMIS) lpMIS.itemHeight = 25 lpMIS.itemWidth = 70 CopyMemory ByVal lParam, lpMIS, Len(lpMIS) End Sub Public Sub OnDrawItem(lParam As Long) 'Îª°´Å¥»æÖÆÑùÃ² Dim lpDIS As DRAWITEMSTRUCT CopyMemory lpDIS, ByVal lParam, Len(lpDIS) Dim mem As Long Dim Object As Long mem = CreateCompatibleDC(hdc) If lpDIS.CtlType = ODT_BUTTON Then If lpDIS.itemState And ODS_SELECTED Then '°´ÏÂÊ±ÍâÃ² drawPic Click Else 'ËÉ¿ªÊ±ÍâÃ² If MouseLeave = True Then drawPic Leave Else drawPic Undo End If End If End If CopyMemory ByVal lParam, lpDIS, Len(lpDIS) End Sub Public Sub LoadPic() '¶ÁÈ¡Í¼Æ¬ ImageHandle(1) = LoadImage(App.hInstance, App.Path & "\" & "1.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) ImageHandle(2) = LoadImage(App.hInstance, App.Path & "\" & "2.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) ImageHandle(3) = LoadImage(App.hInstance, App.Path & "\" & "3.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) End Sub Public Sub drawPic(State As Long) 'Îª°´Å¥»æÖÆ²»Í¬×´Ì¬µÄÍ¼°¸ Dim hdc As Long Dim mem As Long Dim Object As Long hdc = GetDC(CmdHwnd) mem = CreateCompatibleDC(hdc) Object = SelectObject(mem, ImageHandle(State)) BitBlt hdc, 0, 0, 70, 25, mem, 0, 0, SRCCOPY DeleteObject Object DeleteDC mem End Sub

yulijin608 ·¢±íÓÚ 2005-1-6 12:04:00

ÖÕÓÚÉÏ´«ÍêÁË£¬Ï£Íû¶Ô´ó¼Ò»áÓÐËù°ïÖú¡£

tiger8888 ·¢±íÓÚ 2005-1-6 22:06:00

Èç´ËºÃÌù£¬ÕæÊÇ²»¶¥²»ÐÐ£¡

tfyyf ·¢±íÓÚ 2005-1-8 08:21:00

ºÃÌù,¶¥

Ò³: 1 [2] 3 4 5 6 7 8

Ã÷¾­CADÉçÇø's Archiver

Ã÷¾CADÉçÇø's Archiver