کمک در بکاب گیری خودکار هنگام خروج

Collapse
X
Collapse
 
  • صفحه از 1
  • زمان
  • نمایش
حذف همه
new posts
قبلی template بعدی
  • beheshty

    • 2014/03/04
    • 48
    #1

    کمک در بکاب گیری خودکار هنگام خروج

    سلام دوستان
    من از ماکروی زیر برای بکاپ گیری استفاده میکنم حالا چه طور میتوانم این ماکرو طوری تغیر بدم که هنگام خروج با طور اتوماتیک بکاب بگیره یا اینکه در ساعتی مشخص از روز بکاب بگیره
    کد:
      Dim s, M, h, t, yyyy, mm, dd, file As String
    Dim Zaman
    Dim Fn
Public Sub SaveFaileNow()
     
     Call Addres
         

     Fn = Application.GetSaveAsFilename(Zaman)
     ActiveWorkbook.SaveCopyAs Filename:=Fn & ".xlsm"

End Sub

Public Sub Addres()
    file = ActiveWorkbook.Path
    s = Second(Time)
    M = Minute(Time)
    h = Hour(Time)
    t = J_normdate(J_TODAY(1))
    l = Left(t, 4)
    r = Right(t, 2)
    M = Mid(t, 5, 2)
    t = l & "," & M & "," & r
    yyyy = Year(Now)
    mm = Month(Now)
    dd = day(Now)
    If Len(mm) = 1 Then mm = "0" & mm
    If Len(dd) = 1 Then dd = "0" & dd
    If Len(h) = 1 Then h = "0" & h
    If Len(M) = 1 Then M = "0" & M
    If Len(s) = 1 Then s = "0" & s
    
     Zaman = "BACKUP" & t & " - " & (h) & "," & (M) & "," & (s)
End Sub
    برچسب ها: هیچ‌کدام
    • iranweld

      • 2015/03/29
      • 3341
      #2
      با سلام

      کدهای ذیل را در قسمت this workbook کپی نمایید

      کد PHP:
      Private Sub Workbook_BeforeClose(Cancel As Boolean)

      Application.DisplayAlerts = False

      Dim s      , m, h, t, yyyy, mm, dd, file As String

          Dim Zaman
          Dim       Fn
           
                  file = ActiveWorkbook.Path
          s       = Second(Time)
                m = Minute(Time)
                h = Hour(Time)
                t = J_NORMDATE(J_TODAY(1))
                l = Left(t, 4)
                r = Right(t, 2)
                m = Mid(t, 5, 2)
                t = l & "," & m & "," & r
          yyyy       = Year(Now)
                mm = Month(Now)
                dd = day(Now)
          If       Len(mm) = 1 Then mm = "0" & mm
                If Len(dd) = 1 Then dd = "0" & dd
                If Len(h) = 1 Then h = "0" & h
                If Len(m) = 1 Then m = "0" & m
                If Len(s) = 1 Then s = "0" & s
          
           Zaman       = "BACKUP" & t & " - " & (h) & "," & (m) & "," & (s)
           
                  ActiveWorkbook.Save
                  
        ActiveWorkbook      .SaveCopyAs Filename:=file & "\" & Zaman & ".xlsm"
           
           Application.DisplayAlerts = True

      End Sub 
      Click image for larger version Name: Untitled.png Views: 1 Size: 60.5 کیلو بایت ID: 130343
      فایل های پیوست شده

        کامنت

        • beheshty

          • 2014/03/04
          • 48
          #3
          ممنون عالی بود
          من backup را به قسمت ادرس اضافه کردم اما وقتی پوشه ای به نام backup موجود نباشه خطا میده
          فقط چه کدی باید اضافه بشه که اگه پوشه موجود نبود خودش یه پوشه بسازه و فایل بکاپ بریزه داخل اون
          کد:
          Private Sub Workbook_BeforeClose(Cancel As Boolean)

Application.DisplayAlerts = False

Dim s, m, h, t, yyyy, mm, dd, file As String

    Dim Zaman
    Dim Fn
     
      file = ActiveWorkbook.Path
    s = Second(Time)
    m = Minute(Time)
    h = Hour(Time)
    t = J_NORMDATE(J_TODAY(1))
    l = Left(t, 4)
    r = Right(t, 2)
    m = Mid(t, 5, 2)
    t = l & "," & m & "," & r
    yyyy = Year(Now)
    mm = Month(Now)
    dd = day(Now)
    If Len(mm) = 1 Then mm = "0" & mm
    If Len(dd) = 1 Then dd = "0" & dd
    If Len(h) = 1 Then h = "0" & h
    If Len(m) = 1 Then m = "0" & m
    If Len(s) = 1 Then s = "0" & s
    
     Zaman = "BACKUP" & t & " - " & (h) & "," & (m) & "," & (s)
     
      ActiveWorkbook.Save
            
  ActiveWorkbook.SaveCopyAs Filename:=file & "\backup\" & Zaman & ".xlsm"
     
     Application.DisplayAlerts = True

End Sub

            کامنت

            قبلی template بعدی
            چند لحظه..