分类： 编程园地

‘如下两个窗体均为透明，即，可以看到其后的屏幕。

Option Explicit

‘Example
‘Call Translucent(Me.hwnd)’设置当前窗体半透明
‘Translucent oAutoCAD.hwnd’设置已绑定的 AutoCAD 半透明

Private Declare Function GetWindowLong Lib “user32.dll” 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 As Long = -20
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1

‘hWnd是透明窗体的句柄
‘crKey为掩码的颜色,可以用RGB(r,g,b)来指定
‘bAlpha是不透明度,取值范围是（0,255）,其中0代表全透明,255代表不透明
‘dwFlags是透明方式,三种取值方式:
‘LWA_ALPHA时,crKey参数无效,bAlpha参数有效
‘LWA_COLORKEY时,颜色为crKey的地方变为透明,bAlpha参数无效
‘LWA_ALPHA Or LWA_COLORKEY时,crKey的地方将变为全透明,其它地方根据bAlpha参数确定透明度
Public Sub Translucent(ByVal hwnd As Long)
On Error Resume Next
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, RGB(255, 255, 255), 128, LWA_ALPHA
On Error GoTo 0
End Sub

Public Sub NoTranslucent(ByVal hwnd As Long)
On Error Resume Next
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, RGB(255, 255, 255), 255, LWA_ALPHA
On Error GoTo 0
End Sub

Option Explicit
Private Declare Function GetMenu Lib “user32” (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib “user32” (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib “user32” (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib “user32” Alias “ModifyMenuA” (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As String) As Long
Private Declare Function SetMenuItemBitmaps Lib “user32” (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Declare Function GetMenuCheckMarkDimensions Lib “user32” () As Long

‘Example:
‘为当前窗体的第 2 组菜单的第 2 项菜单设置 imgMenu(0) 中的图片
‘Call SetMenuPicture(Me, 2, 3, imgMenu(0))

Public Sub SetMenuPicture(ByVal oForm As Form, ByVal iMenu As Integer, ByVal iSubMenu As Integer, ByVal oImage As Image)
On Error Resume Next
Dim lMenu As Long, lSubMenu As Long, lMenuID As Long
lMenu = GetMenu(oForm.hwnd)
lSubMenu = GetSubMenu(lMenu, iMenu)
lMenuID = GetMenuItemID(lSubMenu, iSubMenu)
lRet = SetMenuItemBitmaps(lMenu, lMenuID, 0, oImage.Picture, 0&)
On Error GoTo 0
End Sub

Sub QuickSort(List() As Double)
Dim I As Double, J As Double, K As Double, b As Double
Dim L As Double, t As Double, r As Double, d As Double
Dim p(1 To 100) As Double
Dim w(1 To 100) As Double
K = 1
p(K) = LBound(List)
w(K) = UBound(List)
L = 1
d = 1
r = UBound(List)
Do
toploop:
If r – L < 9 Then GoTo bubsort I = L J = r While J > I
comp = comp + 1
If List(I) > List(J) Then
swic = swic + 1
t = List(J)
oldx1 = List(J)
oldy1 = J
List(J) = List(I)
oldx2 = List(I)
oldy2 = I
newx1 = List(J)
newy1 = J
List(I) = t
newx2 = List(I)
newy2 = I
d = -d
End If
If d = -1 Then
J = J – 1
Else
I = I + 1
End If
Wend
J = J + 1
K = K + 1
If I – L < r – J Then p(K) = J w(K) = r r = I Else p(K) = L w(K) = I L = J End If d = -d GoTo toploop bubsort: If r – L > 0 Then
For I = L To r
b = I
For J = b + 1 To r
comp = comp + 1
If List(J) <= List(b) Then b = J Next J If I <> b Then
swic = swic + 1
t = List(b)
oldx1 = List(b)
oldy1 = b
List(b) = List(I)
oldx2 = List(I)
oldy2 = I
newx1 = List(b)
newy1 = b
List(I) = t
newx2 = List(I)
newy2 = I
End If
Next I
End If
L = p(K)
r = w(K)
K = K – 1
Loop Until K = 0
End Sub

Sub BubbleSort(List() As Double)
‘Sorts an array using bubble sort algorithm
Dim First As Double, Last As Double
Dim I As Integer, J As Integer
Dim Temp As Double

First = LBound(List)
Last = UBound(List)
For I = First To Last – 1
For J = I + 1 To Last
If List(I) > List(J) Then
Temp = List(J)
List(J) = List(I)
List(I) = Temp
End If
Next J
Next I
End Sub

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

ReDim oPolyline As Object
Dim dVertices(0 To 14) As Double ‘五个点,四段线
‘Define the 2D polyline points
dVertices(0) = 121
dVertices(1) = 234
dVertices(2) = 0
dVertices(3) = 345
dVertices(4) = 45
dVertices(5) = 0
dVertices(6) = 546
dVertices(7) = 67
dVertices(8) = 0
dVertices(9) = 78
dVertices(10) = 89
dVertices(11) = 0
dVertices(12) = 222
dVertices(13) = 444
dVertices(14) = 0
‘Create a lightweight Polyline object in model space
Set oPolyline = oDraw.ModelSpace.AddPolyline(dVertices)
‘设置每段的宽度
For J = 0 To 3
oPolyline .SetWidth J, 2, 3 ‘第 J 段, 起点宽度 2, 终点宽度 3
Next J
oPolyline .Color = 7 ‘acWhite
oPolyline .Update

Private Declare Function FindExecutable Lib “shell32.dll” Alias “FindExecutableA” (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

Public Sub Associate(ByVal FileExtend As String, ByVal FileType As String, ByVal FileDescribe As String, ByVal FileIcon As String, ByVal ProgramName As String) ‘注册文件类型,并设置在浏览器双击打开文件
‘第四位参数说明
‘”C:\WINDOWS\SYSTEM32\shell32.dll,-151″，软件指定图标
‘ProgramName，应用软件图标
‘”%1″，系统指定图标
On Error Resume Next
Dim hkey As Long, ReturnVal As Long
ReturnVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, FileExtend, 0, vbNullString, 0, KEY_ALL_ACCESS, 0, hkey, 0)
If ReturnVal = 0 Then
RegSetValueEx hkey, vbNullString, 0, 1, FileType, LenB(StrConv(FileType, vbFromUnicode)) ‘Len(FileType) 汉字时不准
RegCloseKey hkey
End If
ReturnVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, FileType, 0, vbNullString, 0, KEY_ALL_ACCESS, 0, hkey, 0)
If ReturnVal = 0 Then
RegSetValueEx hkey, vbNullString, 0, 1, FileDescribe, LenB(StrConv(FileDescribe, vbFromUnicode)) ‘Len(FileDescribe) 汉字时不准
RegCloseKey hkey
End If
ReturnVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, FileType & “\DefaultIcon”, 0, vbNullString, 0, KEY_ALL_ACCESS, 0, hkey, 0)
If ReturnVal = 0 Then
RegSetValueEx hkey, vbNullString, 0, 1, FileIcon, LenB(StrConv(FileIcon, vbFromUnicode)) ‘Len(FileIcon) 汉字时不准
RegCloseKey hkey
End If
ReturnVal = RegCreateKeyEx(HKEY_CLASSES_ROOT, FileType & “\Shell\Open\Command”, 0, vbNullString, 0, KEY_ALL_ACCESS, 0, hkey, 0)
If ReturnVal = 0 Then
ProgramName = ProgramName & Space$(1) & “/open %1”
RegSetValueEx hkey, vbNullString, 0, 1, ProgramName, LenB(StrConv(ProgramName, vbFromUnicode)) ‘Len(ProgramName) 汉字时不准
RegCloseKey hkey
End If
On Error GoTo 0
End Sub

Public Sub DisAssociate(ByVal FileExtend As String, ByVal FileType As String) ‘解除在浏览器双击打开文件
DelKey HKEY_CLASSES_ROOT, FileExtend
DelKey HKEY_CLASSES_ROOT, FileType
SHDeleteKey HKEY_CLASSES_ROOT, FileType ‘删除含有子项的项
End Sub

Public Sub SetRightMenu(ByVal sMenuShow As String, ByVal sProgram As String) ‘设置在系统右键菜单打开文件
Call SaveString(HKEY_CLASSES_ROOT, “*\shell\” & sMenuShow & “\command”, “”, sProgram & Space$(1) & “%1″) ‘”” 代表子项 command 的字符串值(默认)
End Sub

Public Sub DisRightMenu(ByVal sMenuShow As String) ‘解除在系统右键菜单打开文件
SHDeleteKey HKEY_CLASSES_ROOT, sMenuShow ‘删除含有子项的项
End Sub

Public Function GetAssociatedProgram(ByVal sExtension As String) As String ‘根据扩展名查找默认打开程序
GetAssociatedProgram = “”
‘If LCase(sExtension) = “dwg” Then
‘GetAssociatedProgram = Trim(GetString(HKEY_CLASSES_ROOT, “AutoCAD\Shell\Open\command”, vbNullString))
‘If GetAssociatedProgram = “” Then GetAssociatedProgram = Trim(GetString(HKEY_LOCAL_MACHINE, “SOFTWARE\Classes\autocad\shell\open\command”, vbNullString)) ‘Belt and braces
‘Exit Function
‘End If
‘ Reading the host program of DWG from the registry.
Dim temp_title As String
Dim temp_path As String
Dim fnum As Integer
Dim result As String
Dim pos As Integer
‘ Get a temporary file name with this extension.
GetTempFile IIf(LCase(sExtension) = “dwg”, “dxf”, sExtension), temp_path, temp_title
‘ Findexecutable cannot find the host program of DWG. The host programs of DXF and DWT can be found, and they are the same host program as DWG.
‘ Make the file.
fnum = FreeFile
Open temp_path & temp_title For Output As fnum
Close fnum
‘ Get the associated executable.
result = Space$(1024)
FindExecutable temp_title, temp_path, result
pos = InStr(result, Chr$(0))
GetAssociatedProgram = Left$(result, pos – 1)
‘ Delete the temporary file.
Kill temp_path & temp_title
End Function

Private Sub GetTempFile(ByVal sExtension As String, ByRef temp_path As String, ByRef temp_title As String)’ Return a temporary file name.
Dim I As Integer
If Left$(sExtension, 1) <> “.” Then sExtension = “.” & sExtension
temp_path = Environ(“TEMP”)
If Right$(temp_path, 1) <> “\” Then temp_path = temp_path & “\”
I = 0
Do
temp_title = “tmp” & Format$(I) & sExtension
If Len(Dir$(temp_path & temp_title)) = 0 Then Exit Do
I = I + 1
Loop
End Sub

‘效果
Public Sub Main()
On Error Resume Next
Dim OptFile As String ‘所选文件的名称
If Len(Command) = 0 Then ‘点击软件本身启动 Command = “”
‘GO ON
Else
If LCase(Left(Command, 6)) = “/open” & Space$(1) Then ‘浏览器双击启动 Command = “/open D:\Test.iso”
OptFile = Right(Command, Len(Command) – 6)
Else ‘系统右键菜单启动 Command = “D:\Test.iso”
OptFile = Command
End If
End If
‘GO ON
On Error GoTo 0
End Sub

‘调用
Sub SetFile()
Dim sProgram As String
sProgram = “C:\Windows\notepad.exe”
Dim sShow As String
sShow = “Open With notepad”
Call Associate(“.iso”, “ISO File”, “”, “%1”, sProgram) ‘注册后缀为 iso 的文件,并确定其默认打开程序为 sProgram
Call SetRightMenu(sShow, sProgram) ‘在系统右键菜单增加一项显示字符为show,并指定由sProgram打开所选文件
End Sub