|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
其他都搞定了，就是没办法将当前工作表的图片保存到指定路径。
Sub CreateFolderAndWriteTxtFile()
Dim fso As Object ' 如果没有添加Scripting Runtime引用，则使用Object
Dim folderPath As String
Dim newFolderName As String
Dim fullFolderPath As String
Dim ws As Worksheet
Dim cell As Range
Dim cellValue As String
Dim filePath As String
Dim txtFile As Integer
Dim objShell As Object, f As Object, ph 'ph must be Variant
Dim pic As Shape '声明一个Shape对象来引用图片
'生成TXT文件和导出图片
' 如果没有添加Scripting Runtime引用，则使用CreateObject
Set fso = CreateObject("Scripting.FileSystemObject")
' 获取当前工作簿的活动工作表
Set ws = ThisWorkbook.ActiveSheet
' 从单元格读取文件夹名称（假设在A1）
Set cell = ws.Range("TXT文件名") ' 或者改为 "TXT文件名" 如果您有一个具体的命名单元格
newFolderName = Trim(cell.Value) ' 使用Trim去除前后空格
' 获取工作簿所在的路径
folderPath = ThisWorkbook.Path
' 构建完整的文件夹路径
fullFolderPath = folderPath & "\" & newFolderName
' 创建文件夹
On Error Resume Next ' 如果文件夹已存在，则忽略错误
fso.CreateFolder fullFolderPath
On Error GoTo 0 ' 恢复正常的错误处理
' 指定TXT文件的路径和名称
filePath = fullFolderPath & "\" & "评论内容.txt"
' 尝试打开（或创建）TXT文件进行写入
On Error Resume Next ' 如果文件已存在，则忽略错误并覆盖
txtFile = FreeFile ' 获取一个未使用的文件号
Open filePath For Output As #txtFile
' 从一个单元格读取内容
cellValue = ws.Range("评论内容").Value ' 确保"评论内容"是有效的单元格引用
' 将单元格内容写入TXT文件
Print #txtFile, cellValue
' 关闭文件
Close #txtFile
'导出图片
Dim shapesToExport() As Variant '数组用于存储要导出的图片引用
shapesToExport = Array("D9", "F9", "D11", "F11", "D13") '假设图片引用已设置为上述单元格
'创建一个新的 Shapes 集合，只包含需要导出的图片
Dim shapeColl As New Collection
For Each pic In ThisWorkbook.ActiveSheet.Shapes
If Application.Index(shapeColl, Application.Match(pic.Name, shapesToExport, 0)) Is Nothing Then
shapeColl.Add pic, pic.Name '只添加匹配的图片
End If
Next pic
If Not shapeColl Is Nothing Then '确认有图片需要导出
Dim savePath As String
savePath = fullFolderPath & "\" & ".png" '修改为你需要保存的路径和文件名
'遍历ShapeCollection并导出图片
For Each pic In shapeColl
pic.ExportAsPicture savePath & "\" & pic.Name & ".png", xlBitmap '每个图片单独保存，并保留原名
Next pic
End If
' 清理
Set fso = Nothing
Set ws = Nothing
Set cell = Nothing
'将刚刚做的数据全部记录到数据库中
' 设置工作表引用
Set wsData = ThisWorkbook.Sheets("数据库")
Set wsSource = ThisWorkbook.Sheets("工作区") ' 数据在哪个子表
' 解密数据库（固定密码）
wsData.Unprotect Password:="digua"
' 获取最后一行并计算新行号
lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
CurrentRow = lastRow + 1
' 读取源数据
CurrentNum = wsSource.Range("序号").Value ' 假设序号在源数据的A2单元格
' 写入数据到数据库
With wsData
.Cells(CurrentRow, 1) = CurrentRow - 1 '
.Cells(CurrentRow, 2) = wsSource.Range("TXT文件名").Value
.Cells(CurrentRow, 3) = wsSource.Range("外放日期").Value
.Cells(CurrentRow, 4) = wsSource.Range("接单对象").Value
.Cells(CurrentRow, 5) = wsSource.Range("宝贝ID").Value
.Cells(CurrentRow, 6) = wsSource.Range("图片张数").Value
.Cells(CurrentRow, 7) = wsSource.Range("图片1").Value
.Cells(CurrentRow, 8) = wsSource.Range("图片2").Value
.Cells(CurrentRow, 9) = wsSource.Range("图片3").Value
.Cells(CurrentRow, 10) = wsSource.Range("图片4").Value
.Cells(CurrentRow, 11) = wsSource.Range("图片5").Value
.Cells(CurrentRow, 12) = wsSource.Range("评论内容").Value
.Cells(CurrentRow, 13) = wsSource.Range("刷单渠道").Value
.Cells(CurrentRow, 14) = wsSource.Range("制单人").Value
.Cells(CurrentRow, 15) = wsSource.Range("备注").Value
' 重新保护数据库
wsData.Protect Password:="digua"
End With
'工作表界面更新
Range("外放日期") = ""
Range("接单对象").Value = ""
Range("宝贝ID").Value = ""
Range("图片张数").Value = ""
Range("图片1").Value = ""
Range("图片2").Value = ""
Range("图片3").Value = ""
Range("图片4").Value = ""
Range("图片5").Value = ""
Range("评论内容").Value = ""
Range("刷单渠道").Value = ""
Range("制单人").Value = ""
Range("备注").Value = ""
Range("交易编号").Value = ""
'做一个快捷查询
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-13 14:50
楼主