调用API函数设计ABOUT窗口

新客网 XKER.COM 2007-02-01 来源：收藏本文

　　1、建立含有如下控件的窗体：

　　控件 NAME CAPTION
　　窗体 FORM1 用VB6.0 设计ABOUT 窗口
　　命令按钮 COMMAND1 关于销售管理系统

　　2、程序清单：

---- Private Declare Function GetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Integer
---- Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon 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 Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

---- Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO) Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)
Private Const GWL_HINSTANCE = (-6)
Private Type SYSTEM_INFO
dwOemID As Long
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
dwReserved As Long
End Type
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Sub Command1_Click()
Dim hinst As Long
Dim icons As Long
Dim abouts As Long
Dim dispx As String
Dim dispy As String
Dim cps As String
Dim space1 As String
Dim space2 As String
hinst = GetWindowWord(Me.hwnd, GWL_HINSTANCE)
icons = ExtractIcon(hinst, "d:\fpw26\foxprow.exe", 0)
Dim sysinfo As SYSTEM_INFO
Dim cls1 As Long
Dim cls2 As Long
Dim secs As Long
Dim bytes As Long
Dim buffs As String
buff = "C:\"
x = GetDriveType(buffs)
x = GetDiskFreeSpace(buffs, secs, bytes, cls1, cls2)
cls1 = cls1 * secs * bytes
cls2 = cls2 * secs * bytes

　　space1 = "C驱动器总共容量：
　　" + Format$(cls2/1024, "#, #") + "千字节"
　　space2 = "C驱动器可用容量：
　　" + Format$(cls1/1024, "#, #") + "千字节"
　　x = GetSystemMetrics(SM_CXSCREEN)
　　dispx = "显示器分辨率：" + Str$(x)

x = GetSystemMetrics(SM_CYSCREEN)
dispy = Str$(x)
Call GetSystemInfo(sysinfo)
Select Case sysinfo.dwProcessorType
Case 386

　　cpus = "处理器类型:386"
　　Case 486
　　cpus = "处理器类型:486"
　　Case 586
　　cpus = "处理器类型:586"
　　End Select
　　abouts = ShellAbout(Me.hwnd, "演示程序",

　　"销售管理系统V2.0版权所有[C]1998-1999"

& Chr$(13) & Chr$(10) & space1 & Chr$(13) & Chr$(10)
& space2 & Chr$(13) & Chr$(10) & cpus + " " + dispx +
"*" + dispy , icons)
End Sub

　　---- 以上程序在Windows98,VISUAL BASIC 6.0 FOR WINDOWS 环境下运行通过. 用户可以将其加入应用系统的ABOUT 菜单项，通过菜单项调用它，效果更好。

上一篇：VB中使窗体右上角的X按钮失效下一篇：VB中调用Windows API的注意事项

【收藏】【评论】【推荐】【投稿】【打印】【关闭】