阅读:1650回复:0
通用对话框专辑之(一)
通用对话框专辑之(一)
使用API调用Winodws各种通用对话框(Common Diaglog)的方法: 1.文件属性对话框 Type SHELLEXECUTEINFO cbSize As Long fMask As Long hwnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long lpIDList As Long '可选参数 lpClass As String '可选参数 hkeyClass As Long '可选参数 dwHotKey As Long '可选参数 hIcon As Long '可选参数 hProcess As Long '可选参数 End Type Const SEE_MASK_INVOKEIDLIST = &HC Const SEE_MASK_NOCLOSEPROCESS = &H40 Const SEE_MASK_FLAG_NO_UI = &H400 Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" _ (SEI As SHELLEXECUTEINFO) As Long Public Function ShowProperties(filename As String, OwnerhWnd As Long) As Long '打开指定文件的属性对话框,如果返回值<=32则出错 Dim SEI As SHELLEXECUTEINFO Dim r As Long With SEI .cbSize = Len(SEI) .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI .hwnd = OwnerhWnd .lpVerb = "properties" .lpFile = filename .lpParameters = vbNullChar .lpDirectory = vbNullChar .nShow = 0 .hInstApp = 0 .lpIDList = 0 End With r = ShellExecuteEX(SEI) ShowProperties = SEI.hInstApp End Function 新建一个工程,添加一个按钮和名为Text1的文本框 把以下代码置入CommandbButton_Click 中 Dim r As Long Dim fname As String '从Text1 中获取文件名及路径 fname = (Text1) r = ShowProperties(fname, Me.hwnd) If r <= 32 Then MsgBox "Error" 2.使用Win95的关于对话框 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 示例: Dim x As Long x = shellabout (Form1.hwnd, "Visual Basic 6.0", _ "Alp Studio MouseTracker Ver 1.0", Form1.icon) 2.调用"捕获打印机端口"对话框 Private Declare Function WNetConnectionDialog Lib "mpr.dll" _ (ByVal hwnd As Long, ByVal dwType As Long) As Long 示例: Dim x As Long x = WNetConnectionDialog(Me.hwnd, 2) 3.调用颜色对话框 Private Type ChooseColor lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As String flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long 将以下代码置入某一事件中: Dim cc As ChooseColor Dim CustColor(16) As Long cc.lStructSize = Len(cc) cc.hwndOwner = Form1.hWnd cc.hInstance = App.hInstance cc.flags = 0 cc.lpCustColors = String$(16 * 4, 0) Dim a Dim x Dim c1 Dim c2 Dim c3 Dim c4 a = ChooseColor(cc) Cls If (a) Then MsgBox "Color chosen:" & Str$(cc.rgbResult) For x = 1 To Len(cc.lpCustColors) Step 4 c1 = Asc(Mid$(cc.lpCustColors, x, 1)) c2 = Asc(Mid$(cc.lpCustColors, x + 1, 1)) c3 = Asc(Mid$(cc.lpCustColors, x + 2, 1)) c4 = Asc(Mid$(cc.lpCustColors, x + 3, 1)) CustColor(x / 4) = (c1) + (c2 * 256) + (c3 * 65536) + (c4 * 16777216) MsgBox "Custom Color " & Int(x / 4) & " = " & CustColor(x / 4) Next x Else MsgBox "Cancel was pressed" End If 4.调用复制磁盘对话框 Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long 示例: 向窗体中添加一个名为Drive1的DriveListBox,将以下代码置入某一事件中 Dim DriveLetter$, DriveNumber&, DriveType& Dim RetVal&, RetFromMsg& DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - 65) DriveType = GetDriveType(DriveLetter) If DriveType = 2 Then 'Floppies, etc RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " _ & DriveNumber & "," & DriveNumber, 1) 'Notice space after Else ' Just in case 'DiskCopyRunDll RetFromMsg = MsgBox("Only floppies can" & vbCrLf & _ "be diskcopied!", 64, "DiskCopy Example") End If 5.调用格式化软盘对话框 Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long 参数设置: fmtID- 3.5" 5.25" ------------------------- 0 1.44M 1.2M 1 1.44M 1.2M 2 1.44M 1.2M 3 1.44M 360K 4 1.44M 1.2M 5 720K 1.2M 6 1.44M 1.2M 7 1.44M 1.2M 8 1.44M 1.2M 9 1.44M 1.2M 选项 0 快速 1 完全 2 只复制系统文件 3 只复制系统文件 4 快速 5 完全 6 只复制系统文件 7 只复制系统文件 8 快速 9 完全 示例:要求同上 Dim DriveLetter$, DriveNumber&, DriveType& Dim RetVal&, RetFromMsg% DriveLetter = UCase(Drive1.Drive) DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number: A=0 DriveType = GetDriveType(DriveLetter) If DriveType = 2 Then 'Floppies, etc RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&) Else RetFromMsg = MsgBox("This drive is NOT a removeable" & vbCrLf & _ "drive! Format this drive?", 276, "SHFormatDrive Example") Select Case RetFromMsg Case 6 'Yes ' UnComment to do it... 'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&) Case 7 'No ' Do nothing End Select End If |
|