分享几个常用的模块
程序代码：
'//! Module Name:mduBrowseForFolder.bas
'//! Intro: 调用浏览文件夹对话框
Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
'Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Private Const MAX_PATH = 260
Private Const BFFM_INITIALIZED = 1
Private Const WM_USER = &H400
'Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
'Private Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
'Private Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
'Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const lPtr = (LMEM_FIXED Or LMEM_ZEROINIT)
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_USENEWUI = &H40
'Private Const BIF_STATUSTEXT = &H4
Private Const BIF_EDITBOX = &H10
'-------------------------------------------
' 目录选择窗(允许指定初始目录、新建文件夹)
'-------------------------------------------
Public Function BrowseForFolder(Optional ByVal hWndOwner As Long, Optional ByVal sTitle As String = "请选择文件夹：", Optional ByVal sSelPath As String = "c:\", Optional NewFolder As Boolean = False) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
If Len(sSelPath) > 0 Then sSelPath = Replace(sSelPath & "\", "\\", "\")
With BI
.hOwner = hWndOwner
.pidlRoot = 0
.lpszTitle = sTitle
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
lpSelPath = LocalAlloc(lPtr, Len(sSelPath))
MoveMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
.lParam = lpSelPath
.ulFlags = IIf(NewFolder, BIF_USENEWUI, BIF_RETURNONLYFSDIRS) Or BIF_EDITBOX
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
'If cancel was pressed, sPath = ""
If Len(BrowseForFolder) > 0 Then
BrowseForFolder = Replace(BrowseForFolder & "\", "\\", "\")
End If
End Function
Private Function BrowseCallbackProcStr(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hwnd, BFFM_SETSELECTIONA, 1, ByVal StrFromPtrA(lpData))
'Call PostMessage(hwnd, BFFM_SETSELECTIONA, 1, ByVal StrFromPtrA(lpData))
Case Else
End Select
End Function
Private Function FARPROC(ByVal pfn As Long) As Long
FARPROC = pfn
End Function
Private Function StrFromPtrA(ByVal lpszA As Long) As String
Dim sRtn As String
sRtn = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal sRtn, ByVal lpszA)
StrFromPtrA = sRtn
End Function
程序代码：
'//! Module Name:mduIni.bas
'//! Intro:读写INI文件
Option Explicit
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Function GetValue(ByVal strIniFile As String, ByVal strSec As String, ByVal strItem As String, Optional ByVal strDef As String = "defaultValue") As String
On Error GoTo errHandler
Dim lRet As Long
Dim strTemp As String
strTemp = String$(254, Chr$(0))
lRet = GetPrivateProfileString(strSec, strItem, strDef, strTemp, 254, strIniFile)
GetValue = Trim$(Left$(strTemp, lRet))
If GetValue = "" Then GetValue = strDef
Exit Function
errHandler:
Debug.Print Err.Number
GetValue = strDef
End Function
Public Function SetValue(ByVal strIniFile As String, ByVal strSec As String, ByVal strItem As String, ByVal strValue As String) As Long
On Error Resume Next
Dim lRet As Long
lRet = WritePrivateProfileString(strSec, strItem, strValue, strIniFile)
SetValue = IIf(lRet = 0, -1, 0)
End Function
程序代码：
'//! Module Name:mduOpenDialog.bas
'//! Intro:调用 打开和另存为对话框
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Const OFN_PATHMUSTEXIST = &H800 '路径必须存在
Private Const OFN_FILEMUSTEXIST = &H1000 '文件必须存在
Private Const OFN_OVERWRITEPROMPT = &H2 '同名文件时提示
'' OPENFILENAME 结构的元素顺序必须按vb6自带的api浏览器里的格式声明。按foxApi V1.5里的声明时出错
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
Public Function ShowOpen(ByVal hwndOwner As Long, Optional ByVal strTitle As String = "打开...", Optional ByVal lpstrFilter As String = "All Files(*.*)" & vbNullChar & "*.*" & vbNullChar, Optional ByVal initDir As String = "c:\", Optional ByVal defExt As String = "*.JTF") As String
On Error Resume Next
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = hwndOwner
OFName.lpstrFilter = lpstrFilter
OFName.lpstrFile = Space$(254)
OFName.nMaxFile = 255
OFName.lpstrFileTitle = Space$(254)
OFName.nMaxFileTitle = 255
OFName.lpstrInitialDir = initDir
OFName.lpstrTitle = strTitle
OFName.lpstrDefExt = defExt
OFName.flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST
'Debug.Print OFName.nFileExtension
If GetOpenFileName(OFName) Then
ShowOpen = Trim$(OFName.lpstrFile)
Else
ShowOpen = ""
End If
End Function
Public Function ShowSave(ByVal hwndOwner As Long, Optional ByVal strTitle As String = "保存为...", Optional ByVal lpstrFilter As String = "All Files(*.*)" & vbNullChar & "*.*" & vbNullChar, Optional ByVal initDir As String = "c:\", Optional ByVal defExt As String = "*.XMC") As String
On Error Resume Next
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = hwndOwner
OFName.hInstance = App.hInstance
OFName.lpstrFilter = lpstrFilter
OFName.lpstrFile = Space$(254)
OFName.nMaxFile = 255
OFName.lpstrFileTitle = Space$(254)
OFName.nMaxFileTitle = 255
OFName.lpstrInitialDir = initDir
OFName.lpstrTitle = strTitle
OFName.flags = OFN_OVERWRITEPROMPT
OFName.lpstrDefExt = defExt
If GetSaveFileName(OFName) Then
ShowSave = Trim$(OFName.lpstrFile)
Else
ShowSave = ""
End If
End Function
感谢分享！
