excel vba 用只读的方法打开文件的问题

Sub a()
      Dim mypath As String
      Dim myfile As String
      mypath = "d:\123\"
      myfile = "axls"
      WorkbooksOpen mypath & myfile, , True
End Sub

在OPEN中的第三个参数。=TRUE表示，为只读方式打开。

测试OK！

1GetAttr 函数
语法：GetAttr(pathname)
功能：获取一个文件、目录、或文件夹的属性。返回一个 Integer值。
返回值
由 GetAttr 返回的值，是下面这些属性值的总和：
常数 值 描述
vbNormal 0 常规
vbReadOnly 1 只读
vbHidden 2 隐藏
vbSystem 4 系统文件
vbDirectory 16 目录或文件夹
vbArchive 32 存档文件
vbalias 64 指定的文件名是别名。只在Macintosh中可用。
说明：若要判断是否设置了某个属性，在 GetAttr 函数与想要得知的属性值之间使用 And 运算符与逐位比较。如果所得的结果不为零，则表示设置了这个属性值。
示例：
DebugPrint GetAttr("F:\testtxt") '若为存档文件，在立即窗口可看到值为32
DebugPrint GetAttr("F:\testtxt") '将属性—高级—可存档文件的勾去掉后，值为0
为判断一个文件是否只读，可用下法:
DebugPrint GetAttr("F:\testtxt") And vbReadOnly
若值非零，说明时只读的。
2复制
'
' （1） 在不需要逐个打开工作簿的情况下,将其有效工作表依次复制到本工作簿的最后
' 新工作表名为:原工作簿名_原工作表名
'
' Sub 复制工作表()
Dim MyObject As Object
Dim strPath As String, strFileName As String, strMyName As String
Dim shtSheet As Worksheet, strShtName As String
Dim intCount As Integer, intShtCount As Integer, i As Integer
ApplicationScreenUpdating = False
strPath = ThisWorkbookPath
strMyName = ThisWorkbookName
intShtCount = ThisWorkbookSheetsCount
With ApplicationFileSearch
NewSearch
LookIn = strPath
SearchSubFolders = False
Filename = "xls"
FileType = msoFileTypeOfficeFiles
If Execute() > 0 Then
intCount = FoundFilesCount
For i = 1 To intCount
strFileName = Replace(FoundFiles(i), strPath & "\", "")
If strFileName <> strMyName Then
Set MyObject = GetObject(strPath & "/" & strFileName)
'下面进行复制工作
For Each shtSheet In MyObjectWorksheets
strShtName = shtSheetName
If MyObjectSheets(strShtName)UsedRangeCount > 1 Then
MyObjectSheets(strShtName)Copy After:=ThisWorkbookSheets(intShtCount)
intShtCount = intShtCount + 1
'重新命名
strShtName = Replace(strFileName, "xls", "_") & strShtName
ThisWorkbookSheets(intShtCount)Name = strShtName
ThisWorkbookSheets("目录")Cells(i + 1, 1) = strShtName
End If
Next shtSheet
End If
Next i
Else
MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", ,"提示"
End If
End With
ThisWorkbookSheets("目录")Select
ApplicationScreenUpdating = True
End Sub
'
'（2） 逐个打开同一目录下的所有工作簿,将其有效工作表依次复制到本工作簿的最后复制完后关闭它
' 新工作表名为:原工作簿名_原工作表名
'
Sub 复制工作表_2()
Dim MyObject As Object
Dim strPath As String, strFileName As String, strMyName As String
Dim shtSheet As Worksheet, strShtName As String
Dim intCount As Integer, intShtCount As Integer, i As Integer
ApplicationScreenUpdating = False
strPath = ThisWorkbookPath
strMyName = ThisWorkbookName
intShtCount = ThisWorkbookSheetsCount
With ApplicationFileSearch
NewSearch
LookIn = strPath
SearchSubFolders = False
Filename = "xls"
FileType = msoFileTypeOfficeFiles
If Execute() > 0 Then
intCount = FoundFilesCount
For i = 1 To intCount
strFileName = Replace(FoundFiles(i), strPath & "\", "")
If strFileName <> strMyName Then
'WorkbooksOpen Filename:=strPath & "/" & strFileName
Set MyObject = GetObject(strPath & "/" & strFileName)
'下面进行复制工作
For Each shtSheet In Workbooks(strFileName)Worksheets
strShtName = shtSheetName
If Workbooks(strFileName)Sheets(strShtName)UsedRangeCount > 1 Then
Workbooks(strFileName)Sheets(strShtName)Copy After:=ThisWorkbookSheets(intShtCount)
intShtCount = intShtCount + 1
'重新命名
strShtName = Replace(strFileName, "xls", "_") & strShtName
ThisWorkbookSheets(intShtCount)Name = strShtName
ThisWorkbookSheets("目录")Cells(i + 1, 1) = strShtName
End If
Next shtSheet
'Workbooks(strFileName)Close
End If
Next i
Else
MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", ,"提示"
End If
End With
ThisWorkbookSheets("目录")Select
ApplicationScreenUpdating = True
End Sub

Sub Read_Word()\x0d\Dim worDoc As object\x0d\Dim wordappl As object\x0d\Dim mydoc As String\x0d\Dim myappl As String\x0d\mydoc = thisworkbookpath & "\" & "文件名doc"　\x0d\'本文档目录下的doc文件，这里可以直接改成路径＋文件名的形式\x0d\Set wordappl = CreateObject("Wordapplication")'设置wordappl对象\x0d\Set worDoc = wordapplDocumentsOpen(mydoc)　\x0d\'打开word文档，mydoc变量指定路径和文件名\x0d\worDocActivate'激活打开的文档\x0d\wordapplSelectionWholeStory '全选文档\x0d\wordapplSelectionCopy'复制选择内容到剪贴板\x0d\worDocApplicationQuit'关闭word文档\x0d\Set WordApp = Nothing'释放对象变量的内存\x0d\Workbooks(1)Sheets(2)Activate '激活excel第一个工作簿的第二个工作表\x0d\ActiveSheetUsedRangeClear　'把当前工作表清空，如果有重要数据，这条删除\x0d\Cells(1, 1)Select'选择A1单元格\x0d\ActiveSheetPaste'粘贴复制的内容\x0d\wordapplquit\x0d\set wordappl =nothing\x0d\End Sub

---