|
马上注册,结交更多好友,享用更多功能^_^
您需要 登录 才可以下载或查看,没有账号?立即注册
x
本帖最后由 ljq5555 于 2011-2-12 10:44 编辑
这些都是我个人收集感觉有用的,不过大多不是我写的,只是作为一个集合存放起来,
一、获取屏幕分辨率:- MsgBox Screen.Width / Screen.TwipsPerPixelX & "x" & Screen.Height / Screen.TwipsPerPixelY
复制代码 二、窗体的简单美化:
函数SetLayeredWindowAttributes
使用这个函数,可以轻松的实现半透明窗体。按照微软的要求,透明窗体窗体在创建时应使用WS_EX_LAYERED参数(用CreateWindowEx),或者在创建后设置该参数(用SetWindowLong),我选用后者。全部函数、常量声明如下:- 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' 其中hwnd是透明窗体的句柄,crKey为颜色值,bAlpha是透明度,取值范围是[0,255],dwFlags是透明方式,可以取两个值:当取值为LWA_ALPHA时,crKey参数无效,bAlpha参数有效;当取值为LWA_COLORKEY时,bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明--这个功能很有用:我们不必再为建立不规则形状的窗体而调用一大堆区域分析、创建、合并函数了,只需指定透明处的颜色值即可,哈哈哈哈!请看具体代码。
- Private Const WS_EX_LAYERED = &H80000
- Private Const GWL_EXSTYLE = (-20)
- Private Const LWA_ALPHA = &H2
- Private Const LWA_COLORKEY = &H1
- '代码一:一个半透明窗体
- Private Sub Form_Load()
- Dim rtn As Long
- rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
- rtn = rtn Or WS_EX_LAYERED
- SetWindowLong hwnd, GWL_EXSTYLE, rtn
- SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA
- End Sub
- '代码二:形状不规则的窗体
- Private Sub Form_Load()
- Dim rtn As Long
- BorderStyler=0
- rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
- rtn = rtn Or WS_EX_LAYERED
- SetWindowLong hwnd, GWL_EXSTYLE, rtn
- SetLayeredWindowAttributes hwnd, &HFF0000, 0, LWA_COLORKEY '将扣去窗口中的蓝色
- End Sub
复制代码 三、用 VB 为文件创建快捷方式- '下面的例子在桌面为文件 C:\a.txt 创建一个快捷方式
- Dim nPath As String, sh, ShortCut
- '获取当前用户的桌面目录
- Set sh = CreateObject("wscript.shell")
- nPath = sh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Desktop")
- ''如果要在开始菜单的程序组中创建快捷方式,将上面的语句换为下面的语句:
- 'nPath = sh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Programs")
- If Right(nPath, 1) <> "" Then nPath = nPath & ""
-
- '创建快捷方式
- ShortF = nPath & "文本文档.lnk"
- Set ShortCut = sh.CreateShortcut(ShortF) '创建一个快捷方式对象
- ShortCut.TargetPath = "C:\a.txt" '快捷方式指向的目标,可以是任意文件
- ShortCut.Save '保存快捷方式
复制代码 四、窗体内控件随窗体的变化而自适应位置和大小(字体不变)- Option Explicit
- Private FormOldWidth As Long
- '保存窗体的原始宽度
- Private FormOldHeight As Long
- '保存窗体的原始高度
- '在调用ResizeForm前先调用本函数
- Public Sub ResizeInit(FormName As Form)
- Dim Obj As Control
- FormOldWidth = FormName.ScaleWidth
- FormOldHeight = FormName.ScaleHeight
- On Error Resume Next
- For Each Obj In FormName
- Obj.Tag = Obj.Left & " " & Obj.Top & " " _
- & Obj.Width & " " & Obj.Height & " "
- Next Obj
- On Error GoTo 0
- End Sub
- '按比例改变表单内各元件的大小,在调用ReSizeForm前先调用ReSizeInit函数
- Public Sub ResizeForm(FormName As Form)
- Dim Pos(4) As Double
- Dim I As Long, TempPos As Long, StartPos As Long
- Dim Obj As Control
- Dim ScaleX As Double, ScaleY As Double
- ScaleX = FormName.ScaleWidth / FormOldWidth
- '保存窗体宽度缩放比例
- ScaleY = FormName.ScaleHeight / FormOldHeight
- '保存窗体高度缩放比例
- On Error Resume Next
- For Each Obj In FormName
- StartPos = 1
- For I = 0 To 4
- '读取控件的原始位置与大小
- TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
- If TempPos > 0 Then
- Pos(I) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
- StartPos = TempPos + 1
- Else
- Pos(I) = 0
- End If
- '根据控件的原始位置及窗体改变大小的比例对控件重新定位与改变大小
- Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, _
- Pos(2) * ScaleX, Pos(3) * ScaleY
- Next I
- Next Obj
- On Error GoTo 0
- End Sub
- Private Sub Form_Load()
- Call ResizeInit(Me) '在程序装入时必须加入
- End Sub
- Private Sub Form_Resize()
- Call ResizeForm(Me) '确保窗体改变时控件随之改变
- End Sub
复制代码 |
|