پرسش تغییر در محل ذخیره

[kazem1359]

سلام در کد زیر با اجرای ان خروجی به صورت jpg در محلی که فایل اصلی قرار دارد ذخیره میشه حالا چطور میشه کد را دستکاری کرد که در محلی ثابت که خودمان در کد می دهیم ذخیره بشه مثلا در درایو D.
ممنون میشم یکی از اساتید پاسخ دهند

Sub ExportMyRange()
    Dim MyChart As String, MyPicture As String, SelAddress As String
    Dim PicFileName As String, ChRngName As String
    Dim PicWidth As Long, PicHeight As Long
    Dim Rng As Range
    
    On Error Resume Next

    Set Rng = Application.Selection
    SelAddress = Replace(Rng.Address, "$", "")
    
    ChRngName = ActiveSheet.Name
    Set Rng = Application.Selection
    Rng.CopyPicture xlScreen, xlBitmap
    Application.ScreenUpdating = False
    ActiveSheet.Paste

    MyPicture = Selection.Name
    With Selection
        PicHeight = .ShapeRange.Height
        PicWidth = .ShapeRange.Width
    End With

    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:=ChRngName
    Selection.Border.LineStyle = 0
    MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

    With ActiveSheet
        With .Shapes(MyChart)
            .Width = PicWidth
            .Height = PicHeight
        End With
        .Shapes(MyPicture).Copy
        With ActiveChart
            .ChartArea.Select
            .Paste
        End With
            
        SelAddress = Replace(SelAddress, ":", "-")
        PicFileName = Mid(ActiveWorkbook.FullName, 1, InStr(1, ActiveWorkbook.FullName, ".") - 1)
        PicFileName = PicFileName & "aa.jpg"
        .ChartObjects(1).Chart.Export Filename:=PicFileName, Filtername:="jpg"
        .Shapes(MyChart).Delete
        .Shapes(MyPicture).Delete
    End With

    MsgBox "ss", vbMsgBoxRight + vbInformation, "aa "
   
NotSave:
    Application.ScreenUpdating = True
End Sub 

[kazem1359]

سلام هیچ دوستی نیست یاری کنه؟