通用对话框专辑（全）

Type SHELLEXECUTEINFO
cbSize As LongfMask As Longhwnd As LonglpVerb As StringlpFile As StringlpParameters As StringlpDirectory As StringnShow As LonghInstApp As LonglpIDList As Long '可选参数
lpClass As String '可选参数
hkeyClass As Long '可选参数
dwHotKey As Long '可选参数
hIcon As Long '可选参数
hProcess As Long '可选参数
EndType

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 AsSHELLEXECUTEINFO
Dim r As Long
WithSEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST OrSEE_MASK_FLAG_NO_UI
.hwnd =OwnerhWnd
.lpVerb = "properties".lpFile =filename
.lpParameters =vbNullChar
.lpDirectory =vbNullChar
.nShow = 0.hInstApp = 0.lpIDList = 0
End Withr =ShellExecuteEX(SEI)
ShowProperties =SEI.hInstApp
End Function

Dim r As Long
Dim fname As String
'从Text1 中获取文件名及路径
fname =(Text1)
r = ShowProperties(fname, Me.hwnd)
If r <= 32 Then MsgBox "Error"

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 Longx = shellabout (Form1.hwnd, "Visual Basic 6.0", _
"Alp Studio MouseTracker Ver 1.0", Form1.icon)

Private Declare Function WNetConnectionDialog Lib "mpr.dll"_
(ByVal hwnd As Long, ByVal dwType As Long) As Long示例:
Dim x As Longx = WNetConnectionDialog(Me.hwnd, 2)

PrivateType ChooseColor
lStructSize As LonghwndOwner As LonghInstance As LongrgbResult As LonglpCustColors As Stringflags As LonglCustData As LonglpfnHook As LonglpTemplateName As String
EndType
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long

Dim cc AsChooseColor
Dim CustColor(16) As Longcc.lStructSize = Len(cc)
cc.hwndOwner =Form1.hWnd
cc.hInstance =App.hInstance
cc.flags = 0cc.lpCustColors = String$(16 * 4, 0)
Dima
Dimx
Dimc1
Dimc2
Dimc3
Dimc4
a =ChooseColor(cc)
Cls
If (a) Then
    MsgBox "Color chosen:" & Str$(cc.rgbResult)

For x = 1 To Len(cc.lpCustColors) Step 4c1 = 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)
Nextx
Else
MsgBox "Cancel was pressed"
End If

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

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

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

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&)
ElseRetFromMsg = MsgBox("This drive is NOT a removeable" & vbCrLf &_
"drive! Format this drive?", 276, "SHFormatDrive Example")
Select CaseRetFromMsg
Case 6 'Yes'UnComment to do it...'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Case 7 'No'Do nothing
End Select
End If

Option Explicit
'调用方式:: string = BrowseForFolders(Hwnd,TitleOfDialog)'例如:String1 = BrowseForFolders(Hwnd, "Select target folder...")
PublicType BrowseInfo
hwndOwner As LongpIDLRoot As LongpszDisplayName As LonglpszTitle As LongulFlags As LonglpfnCallback As LonglParam As LongiImage As Long
EndType
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 AsBrowseInfo
'初始化变量
WithudtBI
.hwndOwner =hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags =BIF_RETURNONLYFSDIRS
End With
'调用 API
lpIDList =SHBrowseForFolder(udtBI)
If lpIDList ThensPath = String$(MAX_PATH, 0)
lResult =SHGetPathFromIDList(lpIDList, sPath)
CallCoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
'如果选择取消, sPath = ""
BrowseForFolder =sPath
End Function

Private/Public Declare Function WNetConnectionDialog Lib "mpr.dll"_
(ByVal hwnd As Long, ByVal dwType As Long) As Longx% = WNetConnectionDialog(Me.hwnd, 1)

PrivateType OPENFILENAME
lStructSize As LonghwndOwner As LonghInstance As LonglpstrFilter As StringlpstrCustomFilter As StringnMaxCustFilter As LongnFilterIndex As LonglpstrFile As StringnMaxFile As LonglpstrFileTitle As StringnMaxFileTitle As LonglpstrInitialDir As StringlpstrTitle As Stringflags As LongnFileOffset As IntegernFileExtension As IntegerlpstrDefExt As StringlCustData As LonglpfnHook As LonglpTemplateName As String
EndType
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long将以下代码置于某一事件中
Dim ofn AsOPENFILENAME
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 = 255ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255ofn.lpstrInitialDir = curdirofn.lpstrTitle = "Our File Open Title"ofn.flags = 0
Dima
a =GetOpenFileName(ofn)
If (a) Then
MsgBox "File to Open: " + Trim$(ofn.lpstrFile)
Else
MsgBox "Cancel was pressed"
End If

PrivateType PrintDlg
lStructSize As LonghwndOwner As LonghDevMode As LonghDevNames As Longhdc As Longflags As LongnFromPage As IntegernToPage As IntegernMinPage As IntegernMaxPage As IntegernCopies As IntegerhInstance As LonglCustData As LonglpfnPrintHook As LonglpfnSetupHook As LonglpPrintTemplateName As StringlpSetupTemplateName As StringhPrintTemplate As LonghSetupTemplate As Long
EndType
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long
'将以下代码置于某一事件中
Dim tPrintDlg AsPrintDlg
tPrintDlg.lStructSize = Len(tPrintDlg)
tPrintDlg.hwndOwner = Me.hwnd
tPrintDlg.hdc =hdc
tPrintDlg.flags = 0tPrintDlg.nFromPage = 0tPrintDlg.nToPage = 0tPrintDlg.nMinPage = 0tPrintDlg.nMaxPage = 0tPrintDlg.nCopies = 1tPrintDlg.hInstance =App.hInstance
lpPrintTemplateName = "Print Page"
Dima
a =PrintDlg(tPrintDlg)
If a ThenlFromPage =tPrintDlg.nFromPage
lToPage =tPrintDlg.nToPage
lMin =tPrintDlg.nMinPage
lMax =tPrintDlg.nMaxPage
lCopies =tPrintDlg.nCopies
PrintMyPage 'Custom printing Subroutine 
End If