通用对话框专辑之(一)

通用对话框专辑之(一)


     使用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