|
|
楼主 |
发表于 2003-4-22 10:11
|
显示全部楼层
|
呵呵,因为代码很简陋,所以不敢公开了.
以上朋友已将文档发送过去了.
主要代码如下:
'===========================
'程序名称:VBA应用程序模板
'代码:ldhyob
'日期:2003年4月
'===========================
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Const WM_SETICON = &H80
Public Const GW_CHILD = 5
Public Const GW_HWNDNEXT = 2
Dim mnuSys As CommandBar '系统菜单条
Dim colVisualCommandBars As New Collection '用于各个工具条
Dim hwa As Long '用于工作簿窗口句柄
Sub SetCommandbars() '只留下系统菜单
Dim cmb As CommandBar
Dim cmc As CommandBarControl
Set mnuSys = Application.CommandBars("Worksheet Menu Bar")
For Each cmb In Application.CommandBars
'隐藏除系统菜单外的所有工具条
If cmb.Name <> "Worksheet Menu Bar" Then
If cmb.Visible Then
colVisualCommandBars.Add cmb, cmb.Name
cmb.Visible = False '隐藏其它工具条
End If
End If
Next
For Each cmc In mnuSys.Controls
'隐藏系统菜单的各弹出菜单
cmc.Visible = False
Next
End Sub
Sub RestoreCommandbars()
Dim cmb As CommandBar
For Each cmb In colVisualCommandBars
cmb.Visible = True
colVisualCommandBars.Remove cmb.Name
Next
End Sub
Sub AddCustonCommands()
Dim cmb As CommandBarControl
Set cmb = AddCustomCommandBarPopup("系统(&S)")
AddCustomCommandBarItem cmb, "退出系统(&X)", "ExitSys", False, True
Set cmb = AddCustomCommandBarPopup("数据处理(&P)")
AddCustomCommandBarItem cmb, "输入报表数据(&I)", "Hello", False, True
AddCustomCommandBarItem cmb, "查看报表数据(&S)", "Hello", True, True
AddCustomCommandBarItem cmb, "查看数据更新(&G)", "Hello", False, True
AddCustomCommandBarItem cmb, "打印指标比率(&P)", "Hello", True, True
Set cmb = AddCustomCommandBarPopup("系统维护(&P)")
AddCustomCommandBarItem cmb, "修改用户(&I)", "Hello", False, True
AddCustomCommandBarItem cmb, "修改表类(&S)", "Hello", False, True
AddCustomCommandBarItem cmb, "修改其它(&G)", "Hello", False, True
AddCustomCommandBarItem cmb, "模拟输入(&R)", "Hello", True, True
Set cmb = AddCustomCommandBarPopup("帮助(&H)")
AddCustomCommandBarItem cmb, "关于(&A)", "ShowAbout", False, True
End Sub
Sub RemoveCustonCommands()
'恢复系统菜单的各弹出菜单
mnuSys.Reset
End Sub
Function AddCustomCommandBarPopup(Caption As String) As CommandBarControl
Dim cmb As CommandBarControl
Set cmb = mnuSys.Controls.Add(msoControlPopup)
cmb.Caption = Caption
cmb.Visible = True
Set AddCustomCommandBarPopup = cmb
End Function
Sub AddCustomCommandBarItem(cmbc As CommandBarControl, _
Caption As String, Macro As String, NewGroup As Boolean, Enable As Boolean)
Dim cbb As CommandBarButton
Set cbb = cmbc.Controls.Add(msoControlButton)
cbb.Caption = Caption
cbb.OnAction = Macro
cbb.BeginGroup = NewGroup
cbb.Enabled = Enable
End Sub
Sub Initialize()
Dim hicon, hWnd, hwnd2 As Long
hicon = ExtractIcon(0, Mid(ThisWorkbook.Path, 1, Len(ThisWorkbook.Path) - 4) + "myexcel.exe", 0) '从myexcel.exe中取图标句柄
hwnd2 = gethw '获取工作簿窗口句柄
SendMessage hwnd2, WM_SETICON, True, hicon '更换工作簿窗口图标为hicon
SendMessage hwnd2, WM_SETICON, False, hicon '刷新,否则图标不能立即得到更新
Application.ScreenUpdating = False
SetCommandbars
AddCustonCommands
With Application
.Caption = "公司业务报表处理系统 2003.04"
With .Windows(1)
.Caption = ""
.WindowState = xlMaximized
End With
End With
With Application
.DisplayFormulaBar = False
.DisplayStatusBar = False
.CommandBars("System").Enabled = False
.CommandBars("Document").Enabled = False
.CommandBars("Toolbar List").Enabled = False
.CommandBars("ply").Enabled = False
End With
Application.ScreenUpdating = True
hWnd = FindWindow(vbNullString, "公司业务报表处理系统 2003.04") '获取窗口句柄
SendMessage hWnd, WM_SETICON, 1, hicon '更换主窗口图标
If Dir(ThisWorkbook.Path + "\test.bmp") <> "" Then
Worksheets("sheet1").Image1.Left = (Application.Width - Worksheets("sheet1").Image1.Width) / 2 - 25
Worksheets("sheet1").Image1.Top = (Application.Height - Worksheets("sheet1").Image1.Height) / 2 - 30
Worksheets("sheet1").Image1.Visible = False
Worksheets("sheet1").Image1.Picture = LoadPicture(ThisWorkbook.Path + "\test.bmp")
End If
Application.OnKey "%{F11}", "InsertProc" '屏蔽ALT+F11 VBA窗口键
End Sub
Sub Restore()
Application.ScreenUpdating = False
Application.Caption = "Microsoft Excel"
RemoveCustonCommands
RestoreCommandbars
With Application
.DisplayFormulaBar = True
.DisplayStatusBar = True
End With
Application.ScreenUpdating = True
End Sub
Sub ExitSys()
Application.Quit
End Sub
Sub InsertProc()
End Sub
Private Function gethw()
Dim TitleToFind As String, ClassToFind As String
If InStr(1, ThisWorkbook.Name, ".") = 0 Then
TitleToFind = ThisWorkbook.Name
Else
TitleToFind = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".") - 1)
End If
ClassToFind = "EXCEL7"
Call FindWindowLike(GetDesktopWindow(), TitleToFind + ".xls", ClassToFind)
gethw = hwa
End Function
Private Function FindWindowLike(ByVal hWndStart As Long, _
WindowText As String, _
Classname As String) As Long
Dim hw As Long
Dim sWindowText As String
Dim sClassname As String
Dim r As Long
Static level As Integer
If level = 0 Then
If hWndStart = 0 Then hWndStart = GetDesktopWindow()
End If
level = level + 1
hw = GetWindow(hWndStart, GW_CHILD)
Do Until hw = 0
Call FindWindowLike(hw, WindowText, Classname)
sWindowText = Space$(255)
r = GetWindowText(hw, sWindowText, 255)
sWindowText = Left(sWindowText, r)
sClassname = Space$(255)
r = GetClassName(hw, sClassname, 255)
sClassname = Left(sClassname, r)
If (sWindowText Like WindowText) And _
(sClassname Like Classname) Then
hwa = hw
Exit Function
End If
hw = GetWindow(hw, GW_HWNDNEXT)
Loop
level = level - 1
End Function |
|
楼主: ldhyob
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2003-4-18 12:53
