PDA

View Full Version : [SOLVED] Macro to Set Page to Print in Particular Range & Adding a Company Logo



Forex-Forex
08-04-2017, 06:43 PM
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
08-05-2017, 04:24 AM
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
08-05-2017, 04:56 AM
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
08-05-2017, 04:57 AM
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
08-05-2017, 06:07 AM
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