如何添加代码移动文件到指定目录（如果指定目录中已经存在同名文件，则直接覆盖）

dzsrmyh · 发表于 2023-4-28 09:24

本帖最后由 dzsrmyh 于 2023-4-28 10:25 编辑

Option Explicit
Sub PrintInvoice()
Dim vFile As Variant, sPath As String, sPDF As String, nI As Integer
Dim acroApp As Acrobat.acroApp
Dim acroAVDoc As Acrobat.acroAVDoc
Dim acroPDDoc As Acrobat.acroPDDoc
Dim oJSO As Object
Dim yy, mm, fso As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vFile = Application.GetOpenFilename("PDF 文件,*.pdf")
If vFile = False Then Exit Sub
sPath = vFile
vFile = Split(sPath, "")
sPath = Left(sPath, Len(sPath) - Len(vFile(UBound(vFile))))
sPDF = Dir(sPath & "*.pdf")
ReDim vFile(1 To 1)
Do While sPDF <> ""
nI = nI + 1
ReDim Preserve vFile(1 To nI)
vFile(nI) = sPDF
sPDF = Dir
Loop
If nI = 0 Then Exit Sub
Set acroApp = CreateObject("AcroExch.App")
Set acroAVDoc = CreateObject("AcroExch.AVDoc")
For nI = 1 To UBound(vFile)
If acroAVDoc.Open(sPath & vFile(nI), "文档转换") Then
Set acroPDDoc = acroAVDoc.GetPDDoc()
Set oJSO = acroPDDoc.GetJSObject
oJSO.SaveAs sPath & "发票.jpg", "com.adobe.acrobat.jpeg"
acroApp.CloseAllDocs
PrintPic sPath & "发票.jpg"
End If
Next
acroApp.Exit
Set oJSO = Nothing
Set acroPDDoc = Nothing
Set acroAVDoc = Nothing
Set acroApp = Nothing
If Dir(sPath & "发票.jpg") <> "" Then Kill sPath & "发票.jpg"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Dim old_path$, new_path$, ext$, fold2, f
Set fso = CreateObject("Scripting.FileSystemObject")
yy = Year(Date)
mm = Month(Date)
<font color="#ff0000">old_path = "d:\桌面"
If Dir(old_path, vbDirectory) = "" Then MkDir old_path
fold2 = old_path & yy & "年"
If Dir(fold2, vbDirectory) = "" Then MkDir fold2
new_path = fold2 & mm & "月"
If Dir(new_path, vbDirectory) = "" Then MkDir new_path
ext = "pdf*"
With fso
For Each f In .getfolder(sPath).Files
If .getextensionname(f.Name) Like ext Then
If Not .fileexists(new_path & f.Name) Then '如何添加代码移动文件到指定目录（如果指定目录中已经存在同名文件）直接覆盖
.Movefile f, new_path & ""</font>
Else
'MsgBox "移动失败，目标文件夹已存在该文件" & f.Name
End If
End If
Next
End With
MsgBox "打印结束！"
End Sub
Private Sub PrintPic(ByVal sPicFile As String)
Dim oPicture As Object, nTop As Double, nLeft As Double
With ActiveSheet
nTop = .[B1].Top
nLeft = .[B1].Left
For Each oPicture In .Shapes
If oPicture.Name <> "CommandButton1" Then oPicture.Delete
Next oPicture
Set oPicture = .Pictures.Insert(sPicFile)
With oPicture
.Name = "Invoice_IMG"
.Top = nTop
.Left = nLeft
End With
.PrintOut
oPicture.Delete
End With
End Sub

复制代码

如何添加代码移动文件到指定目录（如果指定目录中已经存在同名文件，则直接覆盖）

liulang0808 · 发表于 2023-4-28 12:53

https://club.excelhome.net/threa ... tml?_dsign=73cffde5
参考下资料吧

dzsrmyh · 发表于 2023-4-28 14:50

liulang0808 发表于 2023-4-28 12:53
https://club.excelhome.net/thread-1258425-1-1.html?_dsign=73cffde5
参考下资料吧

一头雾水？能请版主添加一下代码吗？谢谢了

liulang0808 · 发表于 2023-4-28 16:09

dzsrmyh 发表于 2023-4-28 14:50
一头雾水？能请版主添加一下代码吗？谢谢了

https://club.excelhome.net/forum ... 170&pid=8004937

3190496160 · 发表于 2023-4-28 16:57

移动文件的代码论坛很多，回过的帖子也很多，自己搜搜看看，
要在你目前的这么多的代码中添加几乎是不可能的，因为，得看懂你的每一句代码才行，而要看懂你的每一句代码不容易

		自动登录	找回密码
密码			免费注册

[求助] 如何添加代码移动文件到指定目录（如果指定目录中已经存在同名文件，则直接覆盖）