|
Dim str As New ADODB.Stream
Dim I, J As Long
Dim MyApp As Excel.Application '定义表
Dim MyBook As Excel.Workbook
Dim MySheet As Excel.Worksheet
If Text1.Text = "" Then '判断路径是否非空
MsgBox "请选择导出路径"
Else
Command2.Enabled = False '在进行数据恢复的时候,使“开始恢复”按钮变为不可用,以便防止进行重复操作,损坏数据库中的数据
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
Call connectDB '调用模块连接数据库
rst.CursorLocation = adUseClient
rst.Open "select * from yuanliao", conn, adOpenDynamic, adLockOptimistic '表连接
Set MyApp = CreateObject("Excel.Application")
MyApp.Visible = False
Set MyBook = MyApp.Workbooks.Add()
Set MySheet = MyBook.Worksheets(1)
'表格列名
MySheet.Cells(1, 1) = "原料编码"
MySheet.Cells(1, 2) = "原石编码"
MySheet.Cells(1, 3) = "照片"
'数据录入
J = 2
Do Until rst.EOF
For I = 1 To rst.Fields.Count
MySheet.Cells(J, I) = rst.Fields(I - 1)
Next
str.Mode = adModeReadWrite
str.Type = adTypeBinary
str.Open
str.Write rst("照片")
str.SaveToFile App.Path + "\test.jpg", adSaveCreateOverWrite '运行时会自动在目录下创立一个test.jpg空图片来存放要显示的图片
Clipboard.Clear '清除剪切板内容
Clipboard.SetData LoadPicture(App.Path + "\test.jpg") '将图片放入剪切板
MySheet.Cells(J, I - 1).Select
MySheet.Paste
MySheet.Cells(J, I - 1).RowHeight = 100 '设置行高
str.Close
rst.MoveNext
J = J + 1
Loop
MyBook.SaveAs Text1.Text + "\原料.xls" '【此处为导出文件路径和名称】
MyApp.Quit
Set MyApp = Nothing
rst.Close
Set rst = Nothing
Set conn = Nothing
MsgBox "导出成功"
Command2.Enabled = True '数据恢复完成后,按钮恢复为可用
End If
上边是源码 我想调整粘贴过去的图片的大小怎么操作 求大神指教
|
|