比如我有数组:Arr_Name()
创建 Excel文件,保存地址为 str_Excel_File_Address,其中该 Excel的Sheet数量为 Ubound(Arr_Name())+2.
Sheet的命名规则为:
第一个Sheet名:Summary
第二个~最后一个的SheetName为 数组Arr_Name()中的值..
这个如何编写呢..
创建 Excel文件,保存地址为 str_Excel_File_Address,其中该 Excel的Sheet数量为 Ubound(Arr_Name())+2.
Sheet的命名规则为:
第一个Sheet名:Summary
第二个~最后一个的SheetName为 数组Arr_Name()中的值..
这个如何编写呢..
Sub Load_Operate_Excel(ByVal str_DB_File_Address As String, ByRef str_Table_Name() As String, ByVal Int_Count As Byte)
'Arr_DB_BackUp_File_Address(i) 文件地址
'Arr_Table_Name(k) 'Sheet 名Dim i As Byte'打开 Excel文件
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = False '操作不可见
Set xlBook = xlApp.Workbooks.Add()
For i = 0 To UBound(str_Table_Name())
If str_Table_Name(i) <> "" Then
Set xlSheet = ActiveWorkbook.Worksheets.Add '添加新sheet
xlSheet.Name = str_Table_Name(i) '重命名新sheet
Else
Exit For
End If
Next i
DoEvents
xlApp.ActiveWorkbook.SaveAs str_DB_File_Address
xlApp.Quit ‘但并没有退出Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = NothingDoEventsEnd Sub
下面得代码也无所谓顺序,都能通过.不过还是应按顺序释放Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = NothingDim i As Byte
Dim str_Table_Name(1) As String
Dim str_DB_File_Address As String
str_Table_Name(0) = "123"
str_Table_Name(1) = "234"
str_DB_File_Address = "D:\AS.XLS"
'打开 Excel文件
Set xlapp = CreateObject("Excel.application")
xlapp.Visible = False '操作不可见
xlapp.Visible = True
Set xlbook = xlapp.Workbooks.Add()
For i = 0 To UBound(str_Table_Name())
If str_Table_Name(i) <> "" Then
Set xlsheet = xlapp.ActiveWorkbook.Worksheets.Add '添加新sheet
xlsheet.Name = str_Table_Name(i) '重命名新sheet
Else
Exit For
End If
Next i
DoEvents
xlapp.ActiveWorkbook.SaveAs str_DB_File_Address
xlapp.Quit '‘但并没有退出[/color]
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
On Error GoTo ErrHandle
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim strsql As String
Dim rsPict As New ADODB.Recordset
If RichTextBox1.Text = " " Then
MsgBox "沒有輸入工號﹐每次可輸入9人工號 ", vbExclamation, "提醒您 "
Exit Sub
End If
'19512,21303,24366,33110,51019,67066,76002,85002,99017
Screen.MousePointer = 11
strsql = "SELECT A.person_no,A.person_name,B.dept_name,A.photo " & _
" FROM person A LEFT JOIN (SELECT position.position_no,position.name,position.dept_no,dept.name AS dept_name FROM position LEFT JOIN dept ON left(position.dept_no,1)+ '0000 '=dept.dept_no)B " & _
" ON A.position_no=B.position_no " & _
" where A.photo is not null and A.enable= '1 ' and A.person_no in( " & RichTextBox1.Text & ") "
rsPict.Open strsql, pubConn, 1, 1
If rsPict.EOF Then
Exit Sub
End If
Set xlApp = CreateObject( "Excel.Application ")
Set xlBook = xlApp.Workbooks.Open( "\\SWEB\Excel\PrintPhoto.xls ")
Set xlSheet = xlBook.Worksheets(2)
xlApp.Visible = False rsPict.MoveFirst
Dim ZX As Single, ZY As Single
Dim i As Integer, j As Integer
With Image1
.Stretch = False
.Visible = False
.Picture = LoadPicture( "\\SWEB\datafile\photo\employee\24115.jpg ")
ZX = .Width / 3000 '假設目標寬度155圖元
ZY = .Height / 3500 '假設目標高度165圖元 .Stretch = True
.Height = Int(.Height / ZY)
.Width = Int(.Width / ZX)
End With
i = 0
j = 0
Do While Not rsPict.EOF
xlSheet.Shapes.AddPicture rsPict.Fields(3).Value, False, True, X1(i), Y1(j), ZX * 32, ZY * 37
xlSheet.Shapes.AddPicture "\\SWEB\datafile\photo\employee\logo.jpg ", False, True, X2(i), Y2(j), ZX * 15, ZY * 8
xlSheet.Cells(X3(i), Y3(i)) = AddSpace(rsPict.Fields(2).Value)
xlSheet.Cells(X3(i) + 2, Y3(i)) = Space(5) & "工號: " & rsPict.Fields(0).Value
xlSheet.Cells(X3(i) + 3, Y3(i)) = Space(5) & "姓名: " & IIf(Len(rsPict.Fields(1).Value) = 2, Left(rsPict.Fields(1).Value, 1) + Space(2) + Right(rsPict.Fields(1).Value, 1), rsPict.Fields(1).Value)
rsPict.MoveNext
i = i + 1
j = j + 1
Loop
xlSheet.Cells(1, 1).Select
xlApp.Visible = True
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Screen.MousePointer = 0
Exit Sub
ErrHandle:
MsgBox "發生意外錯誤,請查看輸入的工號是否正確﹖ ", vbExclamation, "提醒您 "
Screen.MousePointer = 0
End Sub
Set xlBook = Nothing
Set xlApp = Nothing