Sette inn bilder

Ved hjelp av makroene nedenfor kan du sette inn bilder i et angitt område på et regneark.

Sub TestInsertPicture()
    InsertPicture "C:\FolderName\PictureFileName.gif", Range("D10"), True, True
    InsertPictureInRange "C:\FolderName\PictureFileName.gif", Range("B5:D10")
End Sub


Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
    CenterH As Boolean, CenterV As Boolean)
' setter inn et bilde plassert ved det øverste venstre hjørnet til TargetCell
' bildet kan eventuelt sentreres horisontalt og/eller vertikalt
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        If CenterH Then
            w = .Offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .Offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub


Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' setter inn et bilde fra en fil og endrer størrelsen slik at det 
' passer inn i området TargetCells
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing
End Sub

Dokumentet er sist oppdatert 2000-04-15 12:37:25 Utskriftsvennlig versjon