This Code works fine when i step through the code with F8, and i can se the picture. But when i run the code the picture is just a white fore color. The image size changes but doesn't show the actual picture. I've changed the code to get the actual image on to the user form. This was the first code i made that worked without throwing a fault. I have a few pictures on the sheet ICONS and their names are listed in column A from row 2 and down on that sheet. The pictures are in gif and png format.
Option Explicit
Private Sub cmdOK_Click()
' Hämta det valda registret och ikonen från UserFormen
Dim valtRegister As String
Dim valtIcon As String
Dim valtSkala As Double
Dim i As Long
For i = 1 To 8
If Controls("OptionButton" & i).Value = True Then
If i = 1 Then
valtRegister = "Flik 1-5"
valtSkala = 0.5
End If
If i = 2 Then
valtRegister = "Flik 1-10"
valtSkala = 0.5
End If
If i = 3 Then
valtRegister = "Flik 1-15"
valtSkala = 1
End If
If i = 4 Then
valtRegister = "Flik 1-20"
valtSkala = 1
End If
If i = 5 Then
valtRegister = "Flik 1-31"
valtSkala = 1
End If
If i = 6 Then
valtRegister = "Flik A-Ö"
valtSkala = 1
End If
If i = 7 Then
valtRegister = "Flik 1-12"
valtSkala = 1.3
End If
If i = 8 Then
valtRegister = "Flik Jan-Dec"
valtSkala = 1.3
End If
Exit For
End If
Next i
If valtRegister = "" Then
MsgBox "Vänligen välj ett register.", vbExclamation
Exit Sub
End If
valtIcon = cmbIcon.Value
If valtIcon = "" Then
MsgBox "Vänligen välj en ikon från listan.", vbExclamation
Exit Sub
End If
' Kontrollera om det valda bladet finns
If BladFinns(valtRegister) Then
Worksheets(valtRegister).Visible = True
If Worksheets("Flik Jan-Dec").Visible = True And Not valtRegister = "Flik Jan-Dec" Then Worksheets("Flik Jan-Dec").Visible = False
' Infoga ikonen på det valda bladet
InfogaIcon valtRegister, valtIcon, valtSkala
Else
MsgBox "Registeret '" & valtRegister & "' finns inte!", vbExclamation
End If
Unload Me ' Stäng UserFormen efter att ha klickat på OK
End Sub
Private Sub cmbIcon_Change()
Dim lItem As Long
For lItem = 0 To cmbIcon.ListCount - 1
If cmbIcon.Selected(lItem) = True Then
Call Pict(lItem)
Exit Sub
End If
Next
End Sub
Sub Pict(n)
Dim Ans As String
Dim rng As Excel.Range
Dim cht As Excel.ChartObject
Dim Pth As String
Dim Pic As Object
Dim Strpath As String ' Lägg till denna deklaration
Set Pic = Sheets("ICONS").Shapes(cmbIcon.List(n))
Pic.Copy 'Picture xlScreen, xlBitmap
Strpath = AdresseLocal(ThisWorkbook.Path) & "\Temp.jpg"
Set cht = ActiveSheet.ChartObjects.Add(100, 0, Pic.Width, Pic.Height)
cht.Chart.Paste
cht.Chart.Export Strpath
cht.Delete
Set cht = Nothing
Me.imgBild.Picture = LoadPicture(Strpath)
End Sub
Private Sub cmdAvbryt_Click()
Unload Me ' Stäng UserFormen efter att ha klickat på Avbryt
End Sub
Private Sub UserForm_Initialize()
' Fyll ComboBoxen med ikoner från bladet ICONS
Dim ikoner As Range
Set ikoner = Sheets("ICONS").Range("A2:A" & Sheets("ICONS").Cells(Rows.Count, "A").End(xlUp).Row)
cmbIcon.List = ikoner.Value
Call Pict(0)
End Sub
Private Sub InfogaIcon(ByVal bladNamn As String, ByVal iconNamn As String, ByVal skalningsfaktor As Double)
' Kopiera och centrera bilden från "ICONS"-arket till cell A7 på det valda bladet
' Hitta bildens celladress på "ICONS"-arket
Dim wsIcons As Worksheet
Set wsIcons = Sheets("ICONS")
Dim intCell As Integer
Dim bild As Shape
On Error Resume Next
Set bild = wsIcons.Shapes(iconNamn)
On Error GoTo 0
If bladNamn = "Flik 1-5" Then intCell = 7
If bladNamn = "Flik 1-10" Then intCell = 12
If bladNamn = "Flik 1-15" Then intCell = 16
If bladNamn = "Flik 1-20" Then intCell = 21
If bladNamn = "Flik 1-31" Then intCell = 31
If bladNamn = "Flik A-Ö" Then intCell = 21
If bladNamn = "Flik 1-12" Then intCell = 13
If bladNamn = "Flik Jan-Dec" Then intCell = 13
If Not bild Is Nothing Then
' Kopiera bilden
bild.Copy
' Klistra in bilden på det valda bladet
Dim ws As Worksheet
Set ws = Worksheets(bladNamn)
ws.Pictures.Paste.Select
' Centrera och ändra storleken på bilden
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = ws.Cells(intCell, 1).Width * skalningsfaktor
.ShapeRange.Height = ws.Cells(intCell, 1).Height * skalningsfaktor
.Top = ws.Cells(intCell, 1).Top + (ws.Cells(intCell, 1).Height - .ShapeRange.Height) / 2
.Left = ws.Cells(intCell, 1).Left + (ws.Cells(intCell, 1).Width - .ShapeRange.Width) / 2
End With
Application.CutCopyMode = False ' Rensa Urklipp
ActiveSheet.Range("B3").Select
Else
MsgBox "Ikonen '" & iconNamn & "' finns inte på bladet ICONS!", vbExclamation
End If
End Sub
The Sub Pict(n) hade trouble with getting the picture to load in to Me.imgBild.Picture.
I found a work around to this. I have to take the picture and paste it in to an empty chart then make a picture of that chart and save it in to a temp folder then i can use LoadPicture and get the picture to show on the userform as intended. I tried to use .SaveFile on the picture but it kept making it in to an pfd file (pic.jpg.pdf).
This is the solution for the problem
Sub Pict(n)
Dim Pic As Object
Dim tempPath As String
'check n for value
If Me.cmbIcon.List(n) = "" Then Exit Sub
'Show and activate woorksheet with pic and frame
Worksheets("ICONS").Visible = True
Sheets("ICONS").Activate
PicName = Me.cmbIcon.List(n)
' Get pic in to frame export it as jpg and import it in to userform
Blad9.Shapes(PicName).Copy
Blad9.Shapes("PicFrame").Select
Blad9.Select
For Each Sh In ActiveChart.Shapes
Sh.Delete
Next
ActiveChart.Paste
ActiveChart.Shapes(PicName).Width = Blad9.Shapes("PicFrame").Width
ActiveChart.Shapes(PicName).Height = Blad9.Shapes("PicFrame").Height
tempPath = Environ("TEMP") & "\" & PicName & ".jpg"
ActiveChart.Export tempPath
Me.imgBild.Picture = LoadPicture(tempPath)
'remove pick
Kill tempPath
Worksheets("ICONS").Visible = False
End Sub