发表于 2007-4-27 08:09:19
|
显示全部楼层
James Crowley的API代码将API内容添加到顶部的模块中，并通过向表单添加cmdOBrowse_Click（）来使用getfiles函数。Option Explicit
Private Declare Function apiShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Public 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
Public Type SHITEMID 'mkid
cb As Long 'Size of the ID (including cb itself)
abID As Byte 'The item ID (variable length)
End Type
Type ITEMIDLIST 'idl
mkid As SHITEMID
End Type
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Private Declare Function apiGetSystemDirectory& Lib "Kernel32" _
Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long)
Private Declare Function apiGetWindowsDirectory& Lib "Kernel32" _
Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long)
Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
'***App Window Constants***
Public Const WIN_NORMAL = 1 'Open Normal
Public Const WIN_MAX = 3 'Open Maximized
Public Const WIN_MIN = 2 'Open Minimized
Private Const MAX_PATH As Integer = 255
'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal Cx As Long, _
ByVal Cy As Long, ByVal wFlags As Long) As Long
表单内容
Option Explicit
Private Sub cmdIBrowse_Click()
Dim selectFolder As String
Dim bi As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, path$, pos%
' set the type of folder to return
' play with these option constants to see what can be returned
bi.ulFlags = BIF_RETURNONLYFSDIRS 'BIF_RETURNFSANCESTORS 'BIF_BROWSEFORPRINTER + BIF_DONTGOBELOWDOMAIN
' show the browse folder dialog
pidl& = SHBrowseForFolder(bi)
' if displaying the return value, get the selected folder
' If Check1 Then
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
If rtn& Then
' parce & display the folder selection
pos% = InStr(path$, Chr$(0))
selectFolder = Left(path$, pos - 1)
Else
selectFolder = ""
End If
End Sub
Private Sub cmdOBrowse_Click()
Dim selectFolder As String
Dim bi As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, path$, pos%
' set the type of folder to return
' play with these option constants to see what can be returned
bi.ulFlags = BIF_RETURNONLYFSDIRS 'BIF_RETURNFSANCESTORS 'BIF_BROWSEFORPRINTER + BIF_DONTGOBELOWDOMAIN
' show the browse folder dialog
pidl& = SHBrowseForFolder(bi)
' if displaying the return value, get the selected folder
' If Check1 Then
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
If rtn& Then
' parce & display the folder selection
pos% = InStr(path$, Chr$(0))
selectFolder = Left(path$, pos - 1)
Else
selectFolder = ""
End If
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdGO_Click()
Dim FileCountx As Integer
Dim FilesArray() As String
Dim inpath As String
Dim OutPath As String
Dim teststring1 As String
Dim teststring2 As String
Dim MyFilename As String
Dim MyOldFilename As String
Dim MyNewFilename As String
Dim AddText As String
Dim RemoveText As String
FilesArray = GetFiles(inpath)
FileCountx = -1
For FileCountx = LBound(FilesArray) To UBound(FilesArray)
MsgBox MyFilename
'open the file, set the active doc and save it, switch the active doc back,
' open the next and save and so on.
'you can add code to go to a layout in paperspace/modelspace, zoom
'extents, whatever you need.
Next
Unload Me
End Sub
Sub Main()
End Sub
Private Sub Form_Load()
Populate
End Sub
Private Sub Populate()
Dim S As String
Dim PathIName As String
Dim SlashPos As Integer
Dim PathOName As String
'add some form code here
End Sub
Function GetFiles(ByVal FullPath As String) As String()
Dim FileName As String
Dim num_files As Integer
num_files = -1
Dim FilesArray() As String
Dim file_name As String
If Right(FullPath, 1) "" Then FullPath = FullPath & ""
FullPath = FullPath & "*.*"
file_name = Dir(FullPath, vbNormal)
Do While Len(file_name) > 0
If FileName "." And FileName ".." Then ' "" Then FullPath = FullPath & ""
FullPath = FullPath & "*.*"
file_name = Dir(FullPath, vbNormal)
Do While Len(file_name) > 0
If FileName "." And FileName ".." Then
If Right(file_name, 3) = "dxf" Then
num_files = num_files + 1
ReDim Preserve FilesArray9(0 To num_files)
FilesArray9(num_files) = file_name
Else
置顶卡