|
45.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
46.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 "陈锐 ChenReee@Netaddress.com"
.AddItem "陈锐 Reee-Chen@Netaddress.com"
.AddItem "陈锐 Chenrui@hotmail.com"
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
47.将部分菜单放置在窗体的最右段（如帮助等）
在菜单编辑器中在待放置于最右段的菜单前加一标题为空格的菜单，并去掉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
48. 改变屏幕分辨率
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
(编辑:aniston)
|
