|
|
楼主 |
发表于 2024-8-13 14:51
|
显示全部楼层
[广告] 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
