【VB开源代码栏目提醒】:文章导读:在新的一年中,各位网友都进入紧张的学习或是工作阶段。
网学会员整理了VB开源代码-放大镜_VB编的源代码 - 计算机教材的相关内容供大家参考,祝大家在新的一年里工作和学习顺利!
放大镜的所有源
代码 以下保存为文件:Form1.frm VERSION 5.00 Begin
VB.Form Form1 BackColor H00000000 BorderStyle 0 None Caption Form1 ClientHeight 3165 ClientLeft 0 ClientTop 0 ClientWidth 4680 LinkTopic Form1 ScaleHeight 211 ScaleMode 3 Pixel ScaleWidth 312 ShowInTaskbar 0 False StartUpPosition 3 窗口缺省 Begin
VB.Timer Timer1 Interval 10 Left 120 Top 1080 End End Attribute
VB_Name Form1 Attribute
VB_GlobalNameSpace False Attribute
VB_Creatable False Attribute
VB_PredeclaredId True Attribute
VB_Exposed False Option Explicit Private Declare Function GetCursorPos Lib user32 lpPoint As POINTAPI As Long Private Type POINTAPI x As Long y 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 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 Private Declare Function StretchBlt Lib gdi32 ByVal hdc 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 nSrcWidth As Long ByVal nSrcHeight As Long ByVal dwRop As Long As Long Private Declare Function GetDesktopWindow Lib user32 As Long Private Declare Function CreateEllipticRgn Lib gdi32 ByVal X1 As Long ByVal Y1 As Long ByVal X2 As Long ByVal Y2 As Long As Long Private Declare Function SetWindowRgn Lib user32 ByVal hwnd As Long ByVal hRgn As Long ByVal bRedraw As Boolean As Long Private Declare Function DeleteObject Lib gdi32 ByVal hObject As Long As Long Private Declare Function CombineRgn Lib gdi32 ByVal hDestRgn As Long ByVal hSrcRgn1 As Long ByVal hSrcRgn2 As Long ByVal nCombineMode As Long As Long Private Const RGN_DIFF 4 Private Declare Function CreateRectRgn Lib gdi32 ByVal X1 As Long ByVal Y1 As Long ByVal X2 As Long ByVal Y2 As Long As Long Private Declare Function MoveWindow Lib user32 ByVal hwnd As Long ByVal x As Long ByVal y As Long ByVal nWidth As Long ByVal nHeight As Long ByVal bRepaint As Long As Long Private Declare Function GetWindowLong Lib user32 Alias GetWindowLongA ByVal hwnd As Long ByVal nIndex As Long As Long Private Declare Function SetWindowLong Lib user32 Alias SetWindowLongA ByVal hwnd As Long ByVal nIndex As Long ByVal dwNewLong As Long As Long Private Declare Function SetLayeredWindowAttributes Lib user32 ByVal hwnd As Long ByVal crKey As Long ByVal bAlpha As Byte ByVal dwFlags As Long As Long Private Const WS_EX_LAYERED H80000 Private Const GWL_EXSTYLE -20 Private Const LWA_ALPHA H2 Private Const LWA_COLORKEY H1 Private Declare Function SetWindowPos Lib user32 ByVal hwnd As Long ByVal hWndInsertAfter As Long ByVal x As Long ByVal y As Long ByVal cx As Long ByVal cy As Long ByVal wFlags As Long As Long Private Declare Function Rectangle Lib gdi32 ByVal hdc As Long ByVal X1 As Long ByVal Y1 As Long ByVal X2 As Long ByVal Y2 As Long As Long Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Declare Function GetMessage Lib user32 Alias GetMessageA lpMsg As MSG ByVal hwnd As Long ByVal wMsgFilterMin As Long ByVal wMsgFilterMax As Long As Long Private Declare Function TranslateMessage Lib user32 lpMsg As MSG As Long Private Declare Function DispatchMessage Lib user32 Alias DispatchMessageA lpMsg As MSG As Long Private Const WM_MOUSEWHEEL H20A Private Const WM_MOUSEMOVE H200 Private hDesk hDeskDC Private pWidth pHeight Private Sub Form_Load Dim rtn As Long tMSG As MSG 透明 rtn GetWindowLongMe.hwnd GWL_EXSTYLE rtn rtn Or WS_EX_LAYERED SetWindowLong Me.hwnd GWL_EXSTYLE rtn SetLayeredWindowAttributes Me.hwnd 0 255 LWA_ALPHA 置顶一次 SetWindowPos Me.hwnd -1 0 0 0 0 3 屏幕dc hDesk GetDesktopWindow hDeskDC GetDChDesk 初始化大小 Me.Move 0 0 Screen.Height 0.2 Screen.Height 0.2 显示 Me.Show 减少内存消耗 SetProcessWorkingSetSize GetCurrentProcess -1 -1 捕捉滚轮 Do While Me.Enabled DoEvents If GetMessagetMSG 0 0 0 Then Select Case tMSG.message Case WM_MOUSEWHEEL: If tMSG.wParam 0 Then wheel up frm_Setting.WindowEnlarge 1 Else frm_Setting.WindowEnlarge -1 End If End Select TranslateMessage tMSG DispatchMessage tMSG End If Loop End Sub Private Sub Form_MouseMoveButton As Integer Shift As Integer x As Single y As Single Dim p As POINTAPI Dim mWidth mHeight lTemp 随着鼠标移动窗体 If Button 0 Then mWidth pWidth / iMult: mHeight pHeight / iMult GetCursorPos p MoveWindow Me.hwnd p.x - pWidth 2 p.y - pHeight 2 pWidth pHeight True End If End Sub Private Sub Form_MouseUpButton As Integer Shift As Integer x As Single y As Single If Button 2 Then Me.PopupMenu frm_Setting.Menu_Pop End Sub Private Sub Form_Resize Dim tmpRgn hMeRgn 窗口中间挖洞... pWidth Me.Width Screen.TwipsPerPixelX pHeight Me.Height Screen.TwipsPerPixelY hMeRgn CreateRectRgn0 0 pWidth pHeight tmpRgn CreateRectRgnpWidth 2 - 1 pHeight 2 - 1 pWidth 2 2 pHeight 2 2 CombineRgn tmpRgn hMeRgn tmpRgn RGN_DIFF SetWindowRgn Me.hwnd tmpRgn True DeleteObject tmpRgn DeleteObject hMeRgn End Sub Private Sub Form_UnloadCancel As Integer Timer1.Enabled False Me.Enabled False ReleaseDC hDesk hDeskDC End Sub Private Sub Timer1_Timer Dim p As POINTAPI Dim mWidth mHeight lTemp mWidth pWidth / iMult: mHeight pHeight / iMult GetCursorPos p 移动到鼠标旁 MoveWindow Me.hwnd p.x - pWidth 2 p.y - pHeight 2 pWidth pHeight True 绘图 StretchBlt Me.hdc 0 0 pWidth - 1 pHeight - 1 hDeskDC p.x - mWidth 2 p.y - mHeight 2 mWidth mHeight vbSrcCopy Or H40000000 绘图 Rectangle Me.hdc 0 0 pWidth pHeight 框 End Sub 以下保存为文件:Form2.frm VERSION 5.00 Begin
VB.Form Form2 BorderStyle 1 Fixed Single Caption 设置 ClientHeight 1290 ClientLeft 45 ClientTop 360 ClientWidth 3645 LinkTopic Form2 MaxButton 0 False MinButton 0 False ScaleHeight 86 ScaleMode 3 Pixel ScaleWidth 243 Begin
VB.CheckBox Check1 Caption 使用鼠标滚轮调整放大倍数 Height 255 Left 0 TabIndex 5 Top 600 Value 1 Checked Width 2535 End Begin
VB.CommandButton Command1 Caption 显示/隐藏 放大镜 Height 300 Left 0 TabIndex 4 Top 960 Width 3615 End Begin
VB.TextBox Text1 Height 270 Left 960 TabIndex 3 Text 2 Top 240 Width 2655 End Begin
VB.HScrollBar HScroll1 Height 255 Left 960 Max 100 Min 2 TabIndex 0 Top 0 Value 20 Width 2655 End Begin
VB.Label Label2 Caption 放大倍数 Height 255 Left 0 TabIndex 2 Top 240 Width 975 End Begin
VB.Label Label1 Caption 放大镜大小 Height 255 Left 0 TabIndex 1 Top 0 Width 975 End Begin
VB.Menu Menu_Pop Caption Pop Visible 0 False Begin
VB.Menu Menu_Large Caption 放大倍数 Begin
VB.Menu Menu_Large_N Caption 1倍 Index 0 End End Begin
VB.Menu Menu_Large_User Caption 自定义... End Begin
VB.Menu Menu_Hide Caption 隐藏 End Begin
VB.Menu Menu_End Caption 退出 End End End Attribute
VB_Name Form2 Attribute
VB_GlobalNameSpace False Attribute
VB_Creatable False Attribute
VB_PredeclaredId True Attribute
VB_Exposed False Option Explicit Friend Sub WindowEnlargeByVal Offset As Integer Dim iTemp 滚轮改变放大倍数 If Offset 0 Or Check1.Value 0 Then Exit Sub iTemp Offset ValText1.Text If iTemp 50 Or iTemp 1 And ValText1.Text 50 Then iMult ValText1.Text End If End If End Sub 以下保存为文件:MMain.bas Attribute
VB_Name MMain Option Explicit Declare Function SetProcessWorkingSetSize Lib kernel32 ByVal hProcess As Long ByVal dwMinimumWorkingSetSize As Long ByVal dwMaximumWorkingSetSize As Long As Long Declare Function GetCurrentProcess Lib kernel32 As Long Global iMult Global frm_Enlarge As Form1 frm_Setting As Form2 Sub Main Set frm_Enlarge New Form1 Set frm_Setting New Form2 Load frm_Setting Load frm_Enlarge End Sub 以下保存为文件:NoticeIconMoudle.bas Attribute
VB_Name NoticeIconMoudle API函数声明 图标操作 Option Explicit Private Declare Function Shell_NotifyIcon Lib shell32.dll Alias Shell_NotifyIconA ByVal dwMessage As Long lpData As NOTIFYICONDATA As Long Private 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 Global Const WM_LBUTTONDOWN H201 Global Const WM_LBUTTONDBLCLK H203 Global Const WM_RBUTTONUP H205 Private Const NIF_MESSAGE H1 Private Const NIF_TIP H4 Private Const NIM_ADD H0 Private Const NIM_DELETE H2 Private Const NIF_ICON H2 添加图标至通知栏 Public Function Icon_AddiHwnd As Long sTips As String hIcon As Long IconID As Long As Long 参数说明:iHwnd:窗口句柄,sTips:当鼠标移到通知栏图标上时显示的提示内容 hIcon:图标句柄,IconID:图标Id号 Dim IconVa As NOTIFYICONDATA With IconVa .hwnd iHwnd .szTip sTips Chr0 .hIcon hIcon .uID IconID .uCallbackMessage WM_LBUTTONDOWN .cbSize LenIconVa .uFlags NIF_MESSAGE Or NIF_ICON Or NIF_TIP Icon_Add Shell_NotifyIconNIM_ADD IconVa End With End Function 删除通知栏图标参数说明同Icon_Add Function Icon_DeliHwnd As Long lIndex As Long As Long Dim IconVa As NOTIFYICONDATA Dim L As Long With IconVa .hwnd iHwnd .uID lIndex .cbSize LenIconVa End With Icon_Del Shell_NotifyIconNIM_DELETE IconVa End Function 以下保存为文件:工程1.vbp TypeExe FormForm1.frm ReferenceG00020430-0000-0000-C000-0000000000462.00C:WINDOWSsystem32STDOLE2.TLBOLE Automation FormForm2.frm ModuleNoticeIconMoudle NoticeIconMoudle.bas ModuleMMain MMain.bas IconFormForm2 StartupSub Main HelpFile Title工程1 ExeName32放大镜030.exe Path32.. Command32 Name放大镜 HelpContextID0 CompatibleMode0 MajorVer1 MinorVer0 RevisionVer16 AutoIncrementVer1 ServerSupportFiles0 VersionCompanyNamezc CompilationType0 OptimizationType0 FavorPentiumProtm0 CodeViewDebugInfo0 NoAliasing0 BoundsCheck0 OverflowCheck0 FlPointCheck0 FDIVCheck0 UnroundedFP0 StartMode0 Unattended0 Retained0 ThreadPerObject0 MaxNumberOfThreads1 DebugStartupOption0 MS Transaction Server AutoRefresh1 AmicForVB XpInit0 DllInit0 以下保存为文件:工程1.vbw Form1 0 0 0 0 C 44 58 634 373 C Form2 0 0 0 0 C 22 29 612 344 C NoticeIconMoudle 0 0 0 0 C MMain 0 0 0 0 C