VBA monster nearly finished but need a little help. Insert images to spreadsheet - export to PDF.

[Imabus]

Hi all,

I've been doing some writing in VBA over the last few months and i have managed to get some pretty cool things to work. I have been working on a way to get a macro to;

Read through a list of product codes
Look to a central server to see if the image exists
If it does, Fetch the image
insert the image into a second sheet
put the product code and price and title info below it
loop to the next code
insert the image alongside the previous one until there are 5 images in a line
increase row count by 3 and start again until all codes have been processed.
insert a title (user defined) and company logo at the top
export to PDF and save in a folder on users desktop using the title as filename
tell you haw many images were not found
then cleanup so any changes to the original spreadsheet are reversed
'make you a cup of tea
'take the bins out ....

and, it works!

Mostly i found code on here and using Google and filled in the gaps, but there are a last couple of step that i just cant work out.

so, heres the code ... i know its messy and inefficient but i'm scaling the learning curve here and i'm just impressed it works!

Sub Sales_sheet_1111111111111111()
Dim PictureFileName As String, TargetCells As Range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Dim myDir As String
Dim myCell As String
Dim myCount As Single
Dim mycol As String
Dim myrow As String
Dim filename As String
Dim strSpecialFolderPath
Dim objWSHShell As Object
Dim TargetCell As Range
Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop") & "\Sales Sheets\" 'Change this to the location the files are to be copied to
Dim mycode As String
Dim mytitle As String
Dim fail As String
Dim code As String
Dim rrp As String
Dim entercode As String
Dim entertitle As String
Dim pic As Shape
Dim wb As Workbook, wbName As String




Application.ScreenUpdating = False




mycode = InputBox(prompt:="What column contains the B Code?", Default:="A")
Myrrp = InputBox(prompt:="What column contains the RRP?", Default:="c")
mytitle = InputBox(prompt:="What column contains the Title?", Default:="b")
filename = InputBox(prompt:="Please enter Title.", Title:="Sales sheet title", Default:="Bookspeed sales sheet")
myCount = 2 'mycount is the starting row that the file names start at
mycol = "b" 'column where first image will be inserted
myrow = 2
myDir = "\\10.0.0.1\Bookspeed Images\large\"
fail = 0


ActiveSheet.Copy 
ActiveSheet.Name = "Sheet"
Sheets.Add.Name = "Sales Sheet"
If Len(Dir(SpecialFolderPath, vbDirectory)) = 0 Then MkDir SpecialFolderPath
Sheets("Sales Sheet").Range("A:A,C:C,E:E,G:G,I:I,K:K").ColumnWidth = 2.6


Do
    
    myCell = Sheets("sheet").Range(mycode & myCount)
    Title = Sheets("sheet").Range(mytitle & myCount)
    rrp = Sheets("sheet").Range(Myrrp & myCount)
    If Len(Dir(myDir & myCell & ".jpg")) > 0 Then
            Sheets("Sales Sheet").Select
            Sheets("Sales Sheet").Range(mycol + myrow).Select
            Set p = ActiveSheet.Pictures.Insert(myDir & myCell & ".jpg")
    
            ActiveCell.ColumnWidth = 12
            ActiveCell.RowHeight = 100
          
        
  With p
        .ShapeRange.LockAspectRatio = msoTrue
        .width = ActiveCell.width
        .Top = ActiveCell.Top + (ActiveCell.height - p.height)
        '.height = Range(mycol + myrow).height
        '.Top = Range(mycol + myrow).Top
        '.Left = Range(mycol + myrow).Left
        '.Placement = xlMoveAndSize
        '.HorizontalAlignment = xlBottom
        '.ShapeRange.VerticalAlignment = xlCenter


       End With
       
   
entertitle = myrow + 2
entercode = myrow + 1


Sheets("Sales Sheet").Range(mycol + entercode) = myCell & "  " & "£" & rrp
Sheets("Sales Sheet").Range(mycol + entercode).Font.Size = 8
Sheets("Sales Sheet").Range(mycol + entercode).Font.Bold = True
Sheets("Sales Sheet").Range(mycol + entercode).HorizontalAlignment = xlCenter
Sheets("Sales Sheet").Range(mycol + entercode).WrapText = True




Sheets("Sales Sheet").Range(mycol + entertitle) = Title
Sheets("Sales Sheet").Range(mycol + entertitle).Font.Size = 6
Sheets("Sales Sheet").Range(mycol + entertitle).WrapText = True
Sheets("Sales Sheet").Range(mycol + entertitle).HorizontalAlignment = xlCenter
Sheets("Sales Sheet").Range(mycol + entertitle).VerticalAlignment = xlTop
'Sheets("Sales Sheet").Range(mycol + entertitle).Font.Bold = True


      
Select Case mycol
    Case "b"
         mycol = "d"
    Case "d"
         mycol = "f"
    Case "f"
         mycol = "h"
    Case "h"
         mycol = "j"
    Case "j"
         mycol = "b"
         myrow = myrow + 3
End Select
    


Set p = Nothing
 Else: fail = fail + 1
 End If
 
 myCount = myCount + 1
 
Loop Until IsEmpty(Sheets("sheet").Range(mycode & myCount))


Sheets("Sales Sheet").Range("a1") = filename
With Sheets("Sales Sheet").Range("a1")
 .HorizontalAlignment = xlLeft
 .VerticalAlignment = xlTop
 .MergeCells = True
 End With
 With Sheets("Sales Sheet").Range("a1")
 .Name = "Arial"
 .Font.Bold = True
 .Font.Size = 30
 End With
 
'insert logo
If Len(Dir("C:\Users\deanrougvie\Desktop\logo_bookspeed.gif")) > 0 Then _
    Range("j1:k1").Select
    Set p = ActiveSheet.Pictures.Insert("C:\Users\deanrougvie\Desktop\logo_bookspeed.gif")
    With p
        .Top = ActiveCell.Top
        .width = ActiveCell.width
        .Top = ActiveCell.Top + (ActiveCell.height - p.height)
        'ActiveCell.Offset(1).EntireRow.Insert
    End With
Set p = Nothing


Application.DisplayAlerts = False
Sheets("Sheet").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sales Sheet").Select

'export to PDF
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, filename:=SpecialFolderPath & filename & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True




'cleanup
    Set wb = ActiveWorkbook
    wbName = ThisWorkbook.Path & filename & ".xls"
    wb.SaveAs wbName
    wb.Close
    Kill wbName


MsgBox ("PDF created, " & fail & "images not found")




Application.ScreenUpdating = True


End Sub

So, the things i need help with are;

When it exports to PDF obviously it uses the print area markers to set the page size, sometimes this will split the image and description onto different pages. can i define and force it to export a certain size to a page ie Xrows and Xcolumns = a page ... ALWAYS!

I cannot for the life of me work out how to include a footer on each page, can this not be done exporting to PDF? if not how can i define the last row on each page to insert the text? (company info, always the same)

sometimes the image's aspect ratio means when it fits the width of the cell the hight is too large, 90% of the time thats not really an issue, and doing it by height means that 90% of the images would be an issue can i do

 .width = ActiveCell.width
if pic height > than activecell height 
then  .height = ActiveCell.height

i might have just worked out that one there .... ill go test it ... yep that worked

and lastly, when i enter the price as part of

Range(mycol + entercode) = myCell & "  " & "£" & rrp

it will show with the minimum amount of decimal places possible, ive tried numerous ways to force it to "0.00" but if it is possible i have not stumbled over the correct syntax for it yet.

I hope there is someone who has made it this far, and can help, but at least the code above might prove useful for someone trying to do similar things.

Cheers
ImaBus

 

[Worf]

Hello

This macro shows how to define the page size. I'll post on the other questions later...

Sub CustomBreaks()
Dim nr%, nc%, i%
nr = 21                 ' height of page
nc = 11                 ' width of page
With ActiveSheet
    .ResetAllPageBreaks
    ActiveWindow.View = xlNormalView
    For i = 1 To 3
        .HPageBreaks.Add before:=Cells(i * nr, 1)
        .VPageBreaks.Add before:=Cells(1, i * nc)
    Next
End With
ActiveWindow.View = xlPageBreakPreview


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=ThisWorkbook.Path & "\pbreaks.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True


End Sub

 

[Worf]

You should note that the red line of code below is executed whatever the “if” result is, probably not what you intended. This is caused by the line continuation character, which turned it a one-line if statement.

'insert logo
If Len(Dir("C:\Users\deanrougvie\Desktop\logo_bookspeed.gif")) > 0 Then _
    Range("j1:k1").Select
[COLOR=#ff0000]    Set p = ActiveSheet.Pictures.Insert("C:\Users\deanrougvie\Desktop\logo_bookspeed.gif")[/COLOR]
    With p
        .Top = ActiveCell.Top
        .Width = ActiveCell.Width
        .Top = ActiveCell.Top + (ActiveCell.Height - p.Height)
        'ActiveCell.Offset(1).EntireRow.Insert
    End With
Set p = Nothing

Try this for the cell formatting:

Sub TwoDecPlaces()


Range("d4").Value = Format(5.4791, "0.00")


End Sub

 

[Worf]

I cannot for the life of me work out how to include a footer on each page, can this not be done exporting to PDF?

The code I posted earlier included headers and footers on the PDF file without problems (tested with Excel 07 & Adobe Reader X). What happens when you run my macro?

 

[Imabus]

Hi Worf,

Apologies for several weeks going by but i have been off work and only just caught up enough to get back to this.

The page breaks now work like a dream, i have headers and footers with images making it over to the PDF, the only thing i haven't managed to iron out is the decimal points in the

Range(mycol + entercode) = myCell & "  " & "£" & rrp

the way its defined it equals

Range(a1)= "b0000" & " " & "£" & "1.5"

but i want to force the 1.5 to two decimal places, or format the string rrp to currency?

i have seen lots of different ways to do things similar but none seem to work for me.

Cheers,

 

[Worf]

Hi
This example shows how to start with a number, convert it to string and go back to numerical to be formatted.

Sub Pounds()
Dim v#


v = 12.5


Range("f10").Value = "b0000" & " " & "£" & Format(CDbl(CStr(v)), "0.00")


End Sub