Macro to Set Page to Print in Particular Range & Adding a Company Logo

[Forex-Forex]

Dear All

In the attached template to create a questionnaire, could someone in our wonderful community suggests the macro so that when I click on Create Questionnaire, it does the following:

1. Allows me within the macro to specify the print area so that for example I can choose to print on one page

2. Is it possible that by default once you click Create Questionnaire you can have a company logo for example to appear where cell A1 would be or does that have to be manually copied and pasted after you click the button?

I have attached a company logo for example.

Point 1 is probably more important at this stage.

Appreciate any suggestions.

Many thanks

[mdmackillop]

This will allow you to select a print range and put a logo in the header

Sub Test()
    Dim PA As Range
    Set PA = Application.InputBox("Select Print Area", "Questionaire", , , , , , 8)
    ActiveSheet.PageSetup.PrintArea = PA.Address
    ActiveSheet.PageSetup.LeftHeaderPicture.Filename = "K:\Logo.JPG"
End Sub

[Forex-Forex]

Hi VBAX Grand Master

Thank you for your response. My knowledge of VBA is average and I have tried to copy and paste your code and unfortunately the Click Questionnaire is now not working. Would it be possible if you would kindly add the code to the Excel sheet I attached and also the logo so I can see where and how it works?

I would be most grateful.

Thank you.

[Forex-Forex]

This will allow you to select a print range and put a logo in the header

Sub Test()
    Dim PA As Range
    Set PA = Application.InputBox("Select Print Area", "Questionaire", , , , , , 8)
    ActiveSheet.PageSetup.PrintArea = PA.Address
    ActiveSheet.PageSetup.LeftHeaderPicture.Filename = "K:\Logo.JPG"
End Sub

Hi VBAX Grand Master

Thank you for your response. My knowledge of VBA is average and I have tried to copy and paste your code and unfortunately the Click Questionnaire is now not working. Would it be possible if you would kindly add the code to the Excel sheet I attached and also the logo so I can see where and how it works?

I would be most grateful.

Thank you.

[mdmackillop]

Apologies. I hadn't checked out the worksheet code

Sub evtCreateQuestionnaire()

    Dim lngCtrlLeft As Long
    Dim lngCtrlTop As Long
    Dim intLoop As Integer
    Dim intQues As Integer
    Dim intColType As Integer
    Dim intLbl As Integer
    Dim intCtrlStartRow As Integer
    Dim ole As OLEObject
    Dim wksControl As Worksheet
    Dim wksQuestionnaire As Worksheet
    Dim wbkNew As Workbook
    Dim RngControl As Range
    Dim Logo As String
    Dim LogoSize As Long

    Application.ScreenUpdating = False
    Application.StatusBar = "Creating Questionnaire..."
    Set wksControl = shtControl
    Logo = "K:\Logo.JPG"    '@@@@@
    LogoSize = 100             
    
    Set RngControl = Application.InputBox("Select Print Area", "Questionaire", , , , , , 8)     
       '@@@@@@

    wksControl.Unprotect
    Set wbkNew = Application.Workbooks.Add(1)
    Set wksQuestionnaire = wbkNew.Worksheets(1)
    wksQuestionnaire.Name = "Questionnaire"

    'wksQuestionnaire.DrawingObjects.Delete

    lngCtrlLeft = 20
    lngCtrlTop = 25


    intColType = 1
    intLbl = 2

    intCtrlStartRow = 3

    With wksQuestionnaire.Range("C1")
        .Value = wksControl.Range("B1").Value
        .Font.Size = 20
        .Font.Bold = True
    End With
    'For intLoop = intCtrlStartRow To wksControl.Range("A1").CurrentRegion.Rows.Count
    For intLoop = intCtrlStartRow To RngControl.Rows.Count

        Select Case wksControl.Cells(intLoop, intColType).Value
        Case "Ques"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.Label.1")
            intQues = intQues + 1
            Application.StatusBar = "Ques " & intQues & "..."
        Case "Radio"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.OptionButton.1")
            ole.Object.GroupName = "QGrp" & CStr(intQues)
        Case "Check"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.CheckBox.1")
            ole.Object.GroupName = "QGrp" & CStr(intQues)
        Case "Text"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.TextBox.1")
            With ole.Object
                .EnterKeyBehavior = True
                .MultiLine = True
                .ScrollBars = fmScrollBarsVertical
                .WordWrap = True
            End With
        Case "Spin"
            Set ole = wksQuestionnaire.OLEObjects.Add("Forms.SpinButton.1")
        End Select

        If wksControl.Cells(intLoop, intColType).Value = "Ques" Then
            ole.Left = lngCtrlLeft - 5
            lngCtrlTop = lngCtrlTop + 15
            ole.Top = lngCtrlTop
        Else
            ole.Left = lngCtrlLeft
            ole.Top = lngCtrlTop
        End If
        If wksControl.Cells(intLoop, intColType).Value <> "Text" And wksControl.Cells(intLoop, intColType).Value <> "Spin" Then
            If wksControl.Cells(intLoop, intColType).Value = "Ques" Then
                ole.Object.Caption = CStr(intQues) & ". " & wksControl.Cells(intLoop, intLbl).Value
            Else
                ole.Object.Caption = wksControl.Cells(intLoop, intLbl).Value
            End If
            ole.Object.WordWrap = False
            ole.Object.AutoSize = True
        ElseIf wksControl.Cells(intLoop, intColType).Value = "Spin" Then
            ole.Left = ole.Left + 35
            ole.LinkedCell = ole.TopLeftCell.Offset(1, -1).Address
            ole.Object.Max = 0
            ole.Object.Max = 5
        ElseIf wksControl.Cells(intLoop, intColType).Value = "Text" Then
            ole.Object.AutoSize = False
            ole.Object.WordWrap = True
            ole.Object.IntegralHeight = False
            ole.Width = 475
            ole.Height = 30
        End If
        lngCtrlTop = lngCtrlTop + 16
    Next intLoop

    With wksQuestionnaire       '@@@@@
        .Rows(1).RowHeight = LogoSize + 20
    End With
    Call AddPic(Logo, "A1", LogoSize)

    wksControl.Protect
    DoEvents
    wbkNew.Activate

    With ActiveWindow
        .DisplayGridlines = False
        .DisplayHeadings = False
    End With

    wksQuestionnaire.Rows(CStr(ole.TopLeftCell.Offset(3).Row) & ":" & CStr(wksQuestionnaire.Rows.Count)).Hidden = True
    Application.StatusBar = "Saving Questionnaire to Desktop..."

    wbkNew.SaveAs CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "Questionnaire " & Format(Now, "dd-mmm-yy hh-mm-ss")
    DoEvents
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Questionnaire saved on Desktop", vbInformation, "Questionnaire Utility"

    Set ole = Nothing
    Set wksControl = Nothing
    Set wksQuestionnaire = Nothing
    Set wbkNew = Nothing
End Sub


Sub AddPic(f, r, s)  '@@@@@
    Dim pic
    Set pic = ActiveSheet.Pictures.Insert(f)
    With pic
        .Top = Range(r).Top
        .Left = Range(r).Left
        .Width = s
        .Height = s
    End With
End Sub