通用对话框专辑(全)
通用对话框专辑(全)
使用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
使用API调用Winodws各种通用对话框(Common Diaglog)的方法(二)
1.选择目录/文件夹对话框
将以下代码置于一模块中
Option Explicit ' 调用方式:: string = BrowseForFolders(Hwnd,TitleOfDialog) ' 例如:String1 = BrowseForFolders(Hwnd, "Select target folder...") Public Type BrowseInfo hwndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Public Const BIF_RETURNONLYFSDIRS = 1 Public Const MAX_PATH = 260 Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String Dim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo '初始化变量 With udtBI .hwndOwner = hwndOwner .lpszTitle = lstrcat(sPrompt, "") .ulFlags = BIF_RETURNONLYFSDIRS End With '调用 API lpIDList = SHBrowseForFolder(udtBI) If lpIDList Then sPath = String$(MAX_PATH, 0) lResult = SHGetPathFromIDList(lpIDList, sPath) Call CoTaskMemFree(lpIDList) iNull = InStr(sPath, vbNullChar) If iNull Then sPath = Left$(sPath, iNull - 1) End If '如果选择取消, sPath = "" BrowseForFolder = sPath End Function
2.调用"映射网络驱动器"对话框
Private/Public Declare Function WNetConnectionDialog Lib "mpr.dll" _ (ByVal hwnd As Long, ByVal dwType As Long) As Long x% = WNetConnectionDialog(Me.hwnd, 1)
3.调用"打开文件"对话框
Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long 将以下代码置于某一事件中 Dim ofn As OPENFILENAME ofn.lStructSize = Len(ofn) ofn.hwndOwner = Form1.hWnd ofn.hInstance = App.hInstance ofn.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "Rich Text Files (*.rtf)" + Chr$(0) + "*.rtf" + Chr$(0) ofn.lpstrFile = Space$(254) ofn.nMaxFile = 255 ofn.lpstrFileTitle = Space$(254) ofn.nMaxFileTitle = 255 ofn.lpstrInitialDir = curdir ofn.lpstrTitle = "Our File Open Title" ofn.flags = 0 Dim a a = GetOpenFileName(ofn) If (a) Then MsgBox "File to Open: " + Trim$(ofn.lpstrFile) Else MsgBox "Cancel was pressed" End If
4.调用"打印"对话框
Private Type PrintDlg lStructSize As Long hwndOwner As Long hDevMode As Long hDevNames As Long hdc As Long flags As Long nFromPage As Integer nToPage As Integer nMinPage As Integer nMaxPage As Integer nCopies As Integer hInstance As Long lCustData As Long lpfnPrintHook As Long lpfnSetupHook As Long lpPrintTemplateName As String lpSetupTemplateName As String hPrintTemplate As Long hSetupTemplate As Long End Type Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long '将以下代码置于某一事件中 Dim tPrintDlg As PrintDlg tPrintDlg.lStructSize = Len(tPrintDlg) tPrintDlg.hwndOwner = Me.hwnd tPrintDlg.hdc = hdc tPrintDlg.flags = 0 tPrintDlg.nFromPage = 0 tPrintDlg.nToPage = 0 tPrintDlg.nMinPage = 0 tPrintDlg.nMaxPage = 0 tPrintDlg.nCopies = 1 tPrintDlg.hInstance = App.hInstance lpPrintTemplateName = "Print Page" Dim a a = PrintDlg(tPrintDlg) If a Then lFromPage = tPrintDlg.nFromPage lToPage = tPrintDlg.nToPage lMin = tPrintDlg.nMinPage lMax = tPrintDlg.nMaxPage lCopies = tPrintDlg.nCopies PrintMyPage 'Custom printing Subroutine End If