This was posted a short time ago by RB Smissaert. Should give you a flavor.
Watch the workwrap in the email. Might take a bit of work to get it back in
working order.
This code can be simplified enormously by using GetSaveAsFilename instead of
using the Windows API, but it has a number of advantages and I had this code
ready lying around:
Option Explicit
Private Declare Function lstrlen Lib "kernel32" _
Alias "lstrlenW" (ByVal lpString As Long)
As Long
Private Declare Function SetCurrentDirectoryA _
Lib "kernel32" (ByVal lpPathName As String) As
Long
Private Declare Function GetOpenFileName Lib "comdlg32" _
Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As
Long
Private Declare Function GetSaveFileName Lib "comdlg32" _
Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As
Long
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000& 'see comments
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFS_MAXPATHNAME As Long = 260
Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMPT _
Or OFN_NODEREFERENCELINKS
Public Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPROMPT _
Or OFN_HIDEREADONLY
Private Type OPENFILENAME
nStructSize As Long
hWndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
sFile As String
nMaxFile As Long
sFileTitle As String
nMaxTitle As Long
sInitialDir As String
sDialogTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
sDefFileExt As String
nCustData As Long
fnHook As Long
sTemplateName As String
End Type
Private OFN As OPENFILENAME
Private Const MAX_PATH As Long = 260
Private Const ERROR_FILE_NO_ASSOCIATION As Long = 31
Private Const ERROR_FILE_NOT_FOUND As Long = 2
Private Const ERROR_PATH_NOT_FOUND As Long = 3
Private Const ERROR_FILE_SUCCESS As Long = 32 'my constant
Private Const ERROR_BAD_FORMAT As Long = 11
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Sub RangeToText()
Dim arr
Dim strFile As String
Dim strFileName As String
strFileName = Replace(ActiveWorkbook.Name, ".xls", ".txt", 1, -1,
vbTextCompare)
strFile = PickFileFolder(, , , , 1, strFileName, , 1)
If Len(strFile) = 0 Then
Exit Sub
End If
If bFileExists(strFile) Then
If MsgBox(strFile & _
vbCrLf & vbCrLf & _
"Already exists, overwrite this file?", vbYesNo, _
"save range to text file") = vbYes Then
Else
Exit Sub
End If
End If
arr = ActiveWindow.RangeSelection
SaveArrayToText strFile, arr
End Sub
Sub SaveArrayToText(ByVal txtFile As String, _
ByRef arr As Variant, _
Optional ByVal LBRow As Long = -1, _
Optional ByVal UBRow As Long = -1, _
Optional ByVal LBCol As Long = -1, _
Optional ByVal UBCol As Long = -1, _
Optional ByRef fieldArr As Variant)
'this one organises the text file like
'a table by inserting the right line breaks
'------------------------------------------
Dim r As Long
Dim c As Long
Dim hFile As Long
If LBRow = -1 Then
LBRow = LBound(arr, 1)
End If
If UBRow = -1 Then
UBRow = UBound(arr, 1)
End If
If LBCol = -1 Then
LBCol = LBound(arr, 2)
End If
If UBCol = -1 Then
UBCol = UBound(arr, 2)
End If
hFile = FreeFile
Open txtFile For Output As hFile
If IsMissing(fieldArr) Then
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next c
Next r
Else
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next c
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next c
Next r
End If
Close #hFile
End Sub
Function PickFileFolder(Optional bGetFile As Boolean = True, _
Optional bOpen As Boolean, _
Optional strStartFolder As String, _
Optional strFileFilters As String, _
Optional lFilterIndex As Long = 1, _
Optional strFileName As String, _
Optional strTitle As String, _
Optional bStayLastFolder As Boolean, _
Optional bMultiSelect As Boolean, _
Optional lHwnd As Long, _
Optional bSaveWarning As Boolean, _
Optional lPickedFilterIndex As Long = -1) As String
'------------------------------------------------------------
'adapted from Randy Birch:
'
http://vbnet.mvps.org/index.html?code/comdlg/fileopendlg.htm
'------------------------------------------------------------
Dim strCurDir As String
Dim bChDir As Boolean
strCurDir = CurDir
If Len(strStartFolder) = 0 Then
strStartFolder = strCurDir
End If
'create a string of filters for the dialog
If Len(strFileFilters) = 0 Then
strFileFilters = "Text files (*.txt)" & vbNullChar &
"*.txt" & vbNullChar & _
"INI files (*.ini)" & vbNullChar &
"*.ini" & vbNullChar & _
"XLS files (*.xls)" & vbNullChar &
"*.xls" & vbNullChar & _
"Word files (*.doc)" & vbNullChar &
"*.doc" & vbNullChar & _
"Report code files (*.rcf)" & vbNullChar & "*.rcf" &
vbNullChar & _
"Access files (*.mdb)" & vbNullChar &
"*.mdb" & vbNullChar & _
"HTML files (*.html, *htm)" & vbNullChar &
"*.htm*" & vbNullChar & _
"Interbase files (*.gdb)" & vbNullChar & "*gdb"
& vbNullChar & _
"All files (*.*)" & vbNullChar &
"*.*" & vbNullChar & _
"Text or Filter files (*.txt, *.flt)" & vbNullChar &
"*.txt;*.flt" & vbNullChar & _
"Filter files (*.flt*)" & vbNullChar &
"*.flt" & vbNullChar & vbNullChar
End If
If lHwnd = 0 Then
lHwnd = FindWindow("XLMAIN", Application.Caption)
End If
With OFN
'size of the OFN structure
.nStructSize = Len(OFN)
'window owning the dialog
.hWndOwner = lHwnd
'filters (patterns) for the dropdown combo
.sFilter = strFileFilters
'index to the initial filter
.nFilterIndex = lFilterIndex
'default filename, plus additional padding for the user's final
selection(s).
'Must be double-null terminated
If bGetFile Then
.sFile = strFileName & Space$(8192) & vbNullChar & vbNullChar
Else
.sFile = "Select a Folder" & Space$(8192) & vbNullChar & vbNullChar
End If
.nMaxFile = Len(.sFile) 'the size of the buffer
'default extension applied to file if it has no extention
.sDefFileExt = "txt" & vbNullChar & vbNullChar
'space for the file title if a single selection made
'double-null terminated, and its size
.sFileTitle = vbNullChar & Space$(512) & vbNullChar & vbNullChar
.nMaxTitle = Len(OFN.sFileTitle)
'starting folder, double-null terminated
.sInitialDir = strStartFolder & vbNullChar & vbNullChar
'the dialog title
.sDialogTitle = strTitle
'flags
'--------
If bGetFile Then
If bMultiSelect Then
If bStayLastFolder Then
'3701252
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFN_ALLOWMULTISELECT Or OFS_FILE_OPEN_FLAGS
Else
'3701260
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFN_ALLOWMULTISELECT Or OFS_FILE_OPEN_FLAGS Or _
OFN_NOCHANGEDIR
End If
Else
If bOpen Then
If bStayLastFolder Then
'3700740
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFS_FILE_OPEN_FLAGS
Else
'3700748
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFS_FILE_OPEN_FLAGS Or OFN_NOCHANGEDIR
End If
Else
If bStayLastFolder Then
If bSaveWarning Then
'2643982
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFN_NOCHANGEDIR Or OFS_FILE_SAVE_FLAGS
Else
'22540
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFN_NOCHANGEDIR
End If
Else
If bSaveWarning Then
'2643974
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE Or _
OFS_FILE_SAVE_FLAGS
Else
'22532
.flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
OFN_PATHMUSTEXIST Or OFN_SHAREAWARE
End If
End If
End If
End If
Else
'16384
.flags = OFN_SHAREAWARE
End If
End With
If bGetFile Then
If bOpen Then
If GetOpenFileName(OFN) Then
If bMultiSelect Then
PickFileFolder = BuildCSVMultiString(OFN.sFile)
Else
PickFileFolder = TrimNull(OFN.sFile)
End If
bChDir = True
Else
PickFileFolder = ""
End If
Else
If GetSaveFileName(OFN) Then
PickFileFolder = TrimNull(OFN.sFile)
bChDir = True
Else
PickFileFolder = ""
End If
End If
Else
If GetSaveFileName(OFN) Then
PickFileFolder = TrimNull(CurDir)
bChDir = True
Else
PickFileFolder = ""
End If
End If
'so the calling procedure knows what filter was picked
'-----------------------------------------------------
If lPickedFilterIndex > -1 Then
lPickedFilterIndex = OFN.nFilterIndex
End If
If bStayLastFolder = False Then
If bChDir Then
ChDirAPI TrimNull(strCurDir)
End If
End If
End Function
Public Function bFileExists(ByVal sFile As String) As Boolean
Dim lAttr As Long
On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0
End Function
Function BuildCSVMultiString(strString As String) As String
'will take a string of files produced by a multiselect
'where the files are separated by vbNullChar and make into
'a comma-separated string of files
'Will also work if only one file selected
'----------------------------------------------------------
Dim strFolder As String
Dim i As Long
Dim arr
arr = Split(strString, Chr(0))
For i = 0 To UBound(arr)
If i = 0 Then
'if only only one file selected the folder won't be in
'first element and folder names won't have dots
'-----------------------------------------------------
If InStr(1, arr(0), ".", vbBinaryCompare) > 0 Then
BuildCSVMultiString = arr(0)
Exit Function
Else
strFolder = arr(0)
End If
Else
If InStr(1, arr(i), ".", vbBinaryCompare) = 0 Then
'no dot, so not a file anymore
'-----------------------------
Exit Function
End If
If i = 1 Then
BuildCSVMultiString = strFolder & "\" & arr(1)
Else
BuildCSVMultiString = BuildCSVMultiString & "," & _
strFolder & "\" & arr(i)
End If
End If
Next i
End Function
Function TrimNull(strString As String) As String
TrimNull = Left$(strString, lstrlen(StrPtr(strString)))
End Function
Function ChDirAPI(strFolder As String) As Long
'will return 1 on success and 0 on failure
'will work with a UNC path as well
'-----------------------------------------
ChDirAPI = SetCurrentDirectoryA(strFolder)
End Function
RBS
