فایل پی ی اف با تاریخ و زمان در کنار فایل اصلی ذخیره بشه ،چندین کاربرگ بطور تجمیعی فقط در یک پی دی اف ذخیره بشه ، چند کاربرگ مختص ورود اطلاعات ،چند کاربرگ مختص محاسبات و لینک داده ها بین کاربرگهای ورود اطلاعات و گزارشات لینک بشه و یه ارور احتمالی دیگه که اگه فایل اکسل مورد نظر به هر نحو از انحا باز بشه برنامه با مشکل پیغام readonly و save مواجهه میشه که باید بهش جواب بده در حالی که نمی خوایم فایل اکسل رو کاربر ببینه برا همین اول بررسی می کنیم و می بندیمش
تابع بررسی باز بودن یک فایل اکسل
Function IsWorkBookOpen(fileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open fileName For Input Lock Read As #ff
Close ff
ErrNo = err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
اینم نمونه کاملش با ذخیره فایل اکسل جدید در مسیر پروژه
Private Sub Btnamadesazi_Click()
On Error GoTo lab1
Dim Ret, Ret1
Dim xlapp As New Excel.Application
Ret = IsWorkBookOpen("F:\Access\SandHazine\gharardad1.xl sx")
Ret1 = IsWorkBookOpen("F:\Access\SandHazine\khazane.xlsx" )
If Ret = True Then
xlapp.Application.Quit
End If
If Ret1 = True Then
xlapp.Application.Quit
End If
DoCmd.OpenForm "frmpdf"
Set wrk = xlapp.Workbooks.Open("F:\Access\SandHazine\gharard ad1.xlsx")
Set sheetall = wrk.Sheets(Array("dp", "sh", "tk", "ha", "xv"))
xlapp.Application.Visible = True
X = Shamsi() & "-" & Hour(Now()) & "-" & Minute(Now()) & "-" & Second(Now())
namxl = "Jameh#" & X & "#" & ".xlsx"
nampdf = "F:\Access\SandHazine\Jameh " & X & ".pdf"
wrk.Sheets(Array("dp", "sh", "tk", "ha", "xv")).Select
wrk.ExportAsFixedFormat _
Type:=xlTypePDF, _
fileName:=nampdf, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
From:=1, _
To:=25, _
OpenAfterPublish:=False
Forms!frmpdf!WebBrowserpdf.Navigate (nampdf)
wrk.SaveAs CurrentProject.Path & "\Backup\" & namxl
wrk.Save
wrk.Close False
xlapp.Workbooks.Close
xlapp.Application.Quit
Set wrk = Nothing
Set xlapp = Nothing
Exit Sub
lab1:
MsgBox "ÇÔ˜Çá ÏÑ ÓÇÎÊ ÒÇÑÔ áØÝÇ ãÌÏÏÇ ÊáÇÔ äãÇÆíÏ", , "ÎØÇ"
Dim Ret2, Rte3
Ret2 = IsWorkBookOpen("F:\Access\SandHazine\gharardad1.xl sx")
Ret3 = IsWorkBookOpen("F:\Access\SandHazine\khazane.xlsx" )
If Ret2 = True Then
xlapp.Application.Quit
MsgBox "khazane.xlsx closed"
End If
If Ret3 = True Then
xlapp.Application.Quit
End If
DoCmd.Close acForm, "frmpdf"
Exit Sub
End Sub
پاسخ با نقل قول