第二次向execel插入图片 提示实时错误1004 对象range的方法 _global 错误
--------------------编程问答-------------------- 这段代码是在 VB 程序中运行才出错的吧！象 Range、Selection 这类缺省的当前对象必须加上你具体操作的 WorkSheet 对象作为前缀限定。
请贴更多的代码，包括引用 Excel 的 Application、WorkBook、WorkSheet 的部分。
又：贴代码请用输入框上工具条的代码按钮，将代码插到 UBB 标记内。 --------------------编程问答-------------------- 貌似第二次出错。
唉，CSDN没有进步，竟然不能贴附件。
--------------------编程问答-------------------- 2楼没有任何帮助。
Function INSERTPICTURE_Office2003(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, _
Optional ByVal PicHeight As Single = 150) As Boolean
'// Author : Kris @ ExcelFox.com
Dim CA As Range
Dim picPicture
Set CA = Application.Caller
If Val(Application.Version) < 12 Then
For Each picPicture In ActiveSheet.Shapes
If picPicture.TopLeftCell.Address = CA.Address Then
If picPicture.Type = msoLinkedPicture Then
picPicture.Delete
Exit For
End If
End If
Next
Set picPicture = ActiveSheet.Shapes.AddPicture(PictureFullName, 1, 0, CA.Left, CA.Top, PicWidth, PicHeight)
GoTo Finish
End If
For Each picPicture In ActiveSheet.Pictures
If picPicture.TopLeftCell.Address = CA.Address Then
picPicture.Delete
Exit For
End If
Next
Set picPicture = ActiveSheet.Pictures.Insert(PictureFullName)
With picPicture
.Left = CA.Left + 1
.Top = CA.Top + 1
.Width = PicWidth
.Height = PicHeight
End With
INSERTPICTURE_Office2003 = True
Exit Function
Finish:
INSERTPICTURE_Office2003 = True
End Function
ActiveSheet 只适合在 Excel 的宏中使用，VB 调用需要明确对象。
否则就是这种不能多次调用的问题。 --------------------编程问答--------------------
在Excel中测试的，第2次提示“提示实时错误1004”。第一次是成功的。 --------------------编程问答-------------------- 出错的语句位置呢？ --------------------编程问答-------------------- 除 --------------------编程问答--------------------
对不起，以前的Codes有其他代码。在Excel中执行以上代码(INSERTPICTURE_Office2003)是OK的，第2次也行了。 --------------------编程问答-------------------- 我以前也遇到过，好像是结束第一次运行之后，虽然执行了
exApp.Quit
Set exApp = Nothing
但进程中仍然有Excel，第二次执行就出错了。一直没办法解决，论坛好像不可以上传附件，不然就上传给大家指导下一下。 --------------------编程问答-------------------- 经过4楼提醒，还真是ActiveSheet的问题，问题解决了：
贴上代码：
原来的：
'新建文件并增加3个工作表
Private Sub Command2_Click()
Call CreateSheets
End Sub
'打开已有文件并追加3个工作表
Private Sub Command3_Click()
Call CreateSheets
End Sub
Private Sub CreateSheets()
Dim exApp As Excel.Application
Dim exWorkbook As Excel.Workbook
Dim exWorksheet As Excel.Worksheet, st As Excel.Worksheet
Dim i!, nSheet!, sav!
Dim FileN$
Set exApp = CreateObject("Excel.Application")
FileN = App.Path & "\分析表.xls"
If Not Dir(FileN) <> "" Then
Set exWorkbook = exApp.Workbooks.Add
sav = 0
Else
Set exWorkbook = exApp.Workbooks.Open(App.Path & "\分析表.xls")
sav = 1
End If
With exWorkbook
'新建3个表
For i = 1 To 3
nSheet = .Worksheets.Count '已经存在的工作表数量
Set exWorksheet = .Worksheets.Add(after:=.Worksheets(nSheet)) '再最后一个表之后增加
Next i
nSheet = .Worksheets.Count
For i = nSheet - 5 To nSheet - 3
.Sheets(i).Activate ' Select
Call RangMerg '合并单元格
Next i
If sav = 0 Then
.SaveAs FileName:=FileN
Else
.Save
End If
.Close
End With
exApp.Quit
Set exWorkbook = Nothing
Set exApp = Nothing
MsgBox "完毕！"
End Sub
Sub RangMerg()
Call RangeMerge(ActiveSheet.Range("A1:Y1"))
Call FonfSet20(ActiveSheet.Range("A1:Y1"))
Call RangeMerge(ActiveSheet.Range("R2:Y2"))
End Sub
Sub RangeMerge(SelectRange As Range) '合并单元格并作居中处理
With SelectRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
End Sub
修改后的：
'新建文件并增加3个工作表
Private Sub Command2_Click()
Call CreateSheets
End Sub
'打开已有文件并追加3个工作表
Private Sub Command3_Click()
Call CreateSheets
End Sub
Private Sub CreateSheets()
Dim exApp As Excel.Application
Dim exWorkbook As Excel.Workbook
Dim exWorksheet As Excel.Worksheet, st As Excel.Worksheet
Dim i!, nSheet!, sav!
Dim FileN$
Set exApp = CreateObject("Excel.Application")
FileN = App.Path & "\分析表.xls"
If Not Dir(FileN) <> "" Then
Set exWorkbook = exApp.Workbooks.Add
sav = 0
Else
Set exWorkbook = exApp.Workbooks.Open(App.Path & "\分析表.xls")
sav = 1
End If
With exWorkbook
'新建3个表
For i = 1 To 3
nSheet = .Worksheets.Count '已经存在的工作表数量
Set exWorksheet = .Worksheets.Add(after:=.Worksheets(nSheet)) '再最后一个表之后增加
Next i
nSheet = .Worksheets.Count
For i = nSheet - 5 To nSheet - 3
.Sheets(i).Activate ' Select
Call RangMerg(.Sheets(i)) '合并单元格
Next i
If sav = 0 Then
.SaveAs FileName:=FileN
Else
.Save
End If
.Close
End With
exApp.Quit
Set exWorkbook = Nothing
Set exApp = Nothing
MsgBox "完毕！"
End Sub
Sub RangMerg(st As Excel.Worksheet)
Call RangeMerge(st.Range("A1:Y1"))
Call FonfSet20(st.Range("A1:Y1"))
Call RangeMerge(st.Range("R2:Y2"))
End Sub
Sub RangeMerge(SelectRange As Range) '合并单元格并作居中处理
With SelectRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
End Sub
修改部分：
Call RangMerg '合并单元格
改为：
Call RangMerg(.Sheets(i)) '合并单元格
-------------------------------
Sub RangMerg()
Call RangeMerge(ActiveSheet.Range("A1:Y1"))
Call FonfSet20(ActiveSheet.Range("A1:Y1"))
Call RangeMerge(ActiveSheet.Range("R2:Y2"))
End Sub
改为：
Sub RangMerg(st As Excel.Worksheet)
Call RangeMerge(st.Range("A1:Y1"))
Call FonfSet20(st.Range("A1:Y1"))
Call RangeMerge(st.Range("R2:Y2"))
End Sub
补充：VB , VBA
