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

Collapse
X
 
  • زمان
  • نمایش
حذف همه
new posts
  • beheshty

    • 2014/03/04
    • 48

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

    سلام دوستان
    من از ماکروی زیر برای بکاپ گیری استفاده میکنم حالا چه طور میتوانم این ماکرو طوری تغیر بدم که هنگام خروج با طور اتوماتیک بکاب بگیره یا اینکه در ساعتی مشخص از روز بکاب بگیره
    کد:
      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
    mhtyyyymmddfile As String

        Dim Zaman
        Dim 
    Fn
         
          
    file ActiveWorkbook.Path
        s 
    Second(Time)
        
    Minute(Time)
        
    Hour(Time)
        
    J_NORMDATE(J_TODAY(1))
        
    Left(t4)
        
    Right(t2)
        
    Mid(t52)
        
    "," "," 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" " - " & (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

      کامنت

      چند لحظه..