Excel to Pdf

[cagataybaser]

Hello,
I have one excel sheet which has pictures inside and I need to create button to excel to pdf and the pictures shouldnt get bigger when I changed it.
Thank you very much.

 

[ChrisBM]

<code style="margin: 0px; padding: 0px; border: 0px; vertical-align: baseline; font-family: Consolas, Menlo, Monaco, 'Lucida Console', 'Liberation Mono', 'DejaVu Sans Mono', 'Bitstream Vera Sans Mono', 'Courier New', monospace, serif; white-space: inherit; background-image: initial; background-attachment: initial; background-size: initial; background-origin: initial; background-clip: initial; background-position: initial; background-repeat: initial;">Here is some vba code to save the current sheet to pdf:

ActiveSheet.ExportAsFixedFormat _
         Type:=xlTypePDF, _        
         Filename:=[COLOR=#800000]"C:\Sheet.pdf"[/COLOR], _        
         Quality:=xlQualityStandard, _
         IncludeDocProperties:=[COLOR=#800000]True[/COLOR], _        
         IgnorePrintAreas:=[COLOR=#800000]False[/COLOR], _
         OpenAfterPublish:=[COLOR=#800000]True
[/COLOR]

</code>

 

[ParamRay]

.
.

Try the following procedure:

Sub ExportAsPDF()

    Dim Ini As String
    Dim FNm As Variant
    Dim Shp As Shape
    Dim Top As Long
    Dim Btm As Long
    Dim Lft As Integer
    Dim Rgt As Integer
    
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    
    With ActiveWorkbook
        Ini = .Path & Application.PathSeparator
        If InStr(.Name, ".") = 0 Then
            Ini = Ini & .Name
        Else
            Ini = Ini & Left(.Name, InStr(.Name, ".") - 1)
        End If
    End With
    
    FNm = Application.GetSaveAsFilename( _
        InitialFileName:=Ini, _
        FileFilter:="Adobe Acrobat Document (*.pdf), *.pdf", _
        Title:="Save As")
    
    If FNm = False Then Exit Sub
    
    With ActiveSheet
        Top = .Rows.Count
        Lft = .Columns.Count
    End With
    
    Btm = 1
    Rgt = 1
    
    For Each Shp In ActiveSheet.Shapes
        
        With Shp.TopLeftCell
            If .Row < Top Then Top = .Row
            If .Column < Lft Then Lft = .Column
        End With
        
        With Shp.BottomRightCell
            If .Row > Btm Then Btm = .Row
            If .Column > Rgt Then Rgt = .Column
        End With
    
    Next Shp
    
    With ActiveSheet
        .PageSetup.PrintArea = .Range(Cells(Top, Lft), Cells(Btm, Rgt)).Address
    End With
    
    Application.PrintCommunication = False
    
    With ActiveSheet.PageSetup
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    
    Application.PrintCommunication = True
    
    On Error Resume Next
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FNm, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
    
    If Err.Number <> 0 Then
        MsgBox _
            Prompt:= _
                "The action can't be completed because the file is open in Adobe Reader" & _
                vbCrLf & vbCrLf & "Close the file and try again.", _
            Buttons:=vbExclamation, _
            Title:="File In Use"
    End If
    On Error GoTo 0

End Sub