Vriend zocht een manier om een help(gebruiksaanwijzing) in Excel, hij wilde gebruik maken van een Userform om het weer te geven.
Om het Simpel te houden heb ik de volgende oplossing gebruikt: in het werkblad een WordObject gezet.
Het gebied wat het Worddocument beslaat wordt omgezet naar een plaatje in jpg formaat, welke gemakkelijk ingeladen kan worden in een Userform.image
Dit plaatje wordt opgeslagen in Ms Windows tijdelijke map, waaruit de Userform.image het plaatje kan inladen.
Om in een Userform iedere keer een WordObject in te laden duurde te lang, en mocht het help wordbestand er niet zijn, werkt de help niet.
Vandaar de oplossing om een WordObject in te voegen in een Worksheet, en daar dan een jpg plaatje van te maken
Hoop dat er iemand wat aan heeft. Heb de code voorzien van Rem regels.
Module Code
Code:
Option Explicit
'Type used for RangeToImage
Public Type PicFormat
Height As Double
Width As Double
PicTemDir As String
PicFormatError As Boolean
PicFormatErrorMessage As String
End Type
'************************************************************************************************************************************************
'****** RangeToImage - created by Mr. Magoo The Netherlands - january 2021 ******
'************************************************************************************************************************************************
'****** Creates a picture from a Range in a worksheet ******
'****** put the picture in the temporary folder of Ms Windows ******
'****** Return the values in the variable Type PicFormat ******
'****** PicFormat has the following variable members ******
'************************************************************************************************************************************************
'****** Public Type PicFormat 'Type ******
'****** Height As Double 'Returns the height of the (Range) Picture in pixels ******
'****** Width As Double 'Returns the width of the (Range) Picture in pixels ******
'****** PicTemDir As String 'the temporary directory where the picture is = Directory + picture.jpg ******
'****** PicFormatError As Boolean ' PicFormatError = False -> No Error - PicFormatError = True -> Error has occurred ******
'****** PicFormatErrorMessage as String 'Returns the Error message -> No Range, -> Worksheet not Exist ******
'****** End Type ******
'************************************************************************************************************************************************
'****** Variable: WorksheetName = the worksheet name where the Range to picture state ******
'****** Variable: ImageRange = The range from the Worksheet what gets converted to image ******
'****** ******
'****** Example Call: PicFormat(Type)=RangeToImage("WorksheetName",Range("A1:C10") -> Picture info are returns in pictureType ******
'************************************************************************************************************************************************
Public Function RangeToImage(WorksheetName As String, ImageRange As Range) As PicFormat
'WorksheetName = the worksheet name where the Range to picture state
'ImageRange = The range what gets converted to image
Dim Tempfile As String 'Picture comes in here which is stored in tempdirectory "C:\Users\Username\AppData\Local\Temp\"
Dim ErrorrMessage As String 'If error, you can see, what the problem was
'Init
'RangeToImage.PicFormatError = False
ErrorrMessage = Empty
'Control if range
If TypeName(ImageRange) <> "Range" Then
RangeToImage.PicFormatErrorMessage = "No Range has been specified which should be converted to Picture"
RangeToImage.PicFormatError = True
End If
'Control if Worksheet exist in this Workbook
If WorksheetExist(WorksheetName) = False Then
If RangeToImage.PicFormatErrorMessage <> Empty Then
RangeToImage.PicFormatErrorMessage = RangeToImage.PicFormatErrorMessage & vbNewLine & " And" & vbNewLine & "The Worksheet: " & WorksheetName & "Is not exist in this Workbook!"
RangeToImage.PicFormatError = True
Else
RangeToImage.PicFormatErrorMessage = "The Worksheet: " & WorksheetName & "Is not exist in this Workbook!"
RangeToImage.PicFormatError = True
End If
End If
'If error stop function RangeToImage
If RangeToImage.PicFormatError = True Then GoTo Error_RangeToImage 'ook nog ander controleren
'******* Convert start of range to picture ******
'Take temp directory and tempfile
Tempfile = (Environ("Temp") & Application.PathSeparator & "Temp.jpg") 'No Png file, can userform.image not load
'Delete tempfile if exist
On Error Resume Next
Kill Tempfile
On Error GoTo 0
'Set Error for unknown critical error
On Error GoTo CriticalError_RangeToImage
'Control or Range Exist
If TypeName(ImageRange) = "Range" Then
With ThisWorkbook.Worksheets(WorksheetName)
'Copy Range
.Range(ImageRange.Address).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'set the Height en Width from the picture -> you can use this in the image in the Userform
RangeToImage.Height = .Range(ImageRange.Address).Height + 1
RangeToImage.Width = .Range(ImageRange.Address).Width + 1
'Take range and convert to Picture -> Make one ChartObjects is for temporary use
With .ChartObjects.Add(Left:=.Range(ImageRange.Address).Left, Top:=.Range(ImageRange.Address).Top, _
Width:=.Range(ImageRange.Address).Width + 1, Height:=.Range(ImageRange.Address).Height + 1)
DoEvents 'Temporarily pauses a running macro,Take time for Worksheet functions
With .Chart
Do Until .Pictures.Count = 1
DoEvents 'Temporarily pauses a running macro,Take time for Worksheet functions
.Paste 'Copy to ChartObjects
Loop
.ChartArea.Format.Line.Visible = msoFalse 'No Line
.Export Tempfile 'Save the image of the ChartObject in the directory Temp
RangeToImage.PicFormatError = False 'There are no mistakes
End With
.Delete 'Delete the ChartObject
End With
End With
'Return the temporary directory + image.jpg. This can be used in Image..Picture = LoadPicture (TempDirPicure)
RangeToImage.PicTemDir = Tempfile
End If
Exit Function 'Exit Everything went well
Error_RangeToImage: 'Exit if no Range of Worksheet not Exist
Exit Function
CriticalError_RangeToImage: 'Exit if unknown error
RangeToImage.PicFormatErrorMessage = "An unknown error has occurred! Error: " & Err & " -> " & Err.Description
RangeToImage.PicFormatError = True
End Function
'Check of worksheet exists in active workbook
Private Function WorksheetExist(WorksheetName As String) As Boolean
Dim Worksheet As Integer 'Worksheet Number
'Init
WorksheetExist = False
With ThisWorkbook
For Worksheet = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(Worksheet).Name = WorksheetName Then
WorksheetExist = True 'Worksheet exist in workbook
Exit Function
End If
Next
End With
End Function
Userform Code
Code:
Option Explicit
Private Sub UserForm_Initialize()
Dim TempPic As String, Picture As PicFormat
Picture = RangeToImage("Blad1", Range("A1:H29"))
If Picture.PicFormatError = False Then
With Me
.ImageFrame.Left = 10
.ImageFrame.Top = 10
.ImageFrame.Height = Me.Height - 50
.ImageFrame.Width = Picture.Width + 18
.ImageFrame.ScrollHeight = Picture.Height
.Image.Picture = LoadPicture(Picture.PicTemDir)
.Image.Left = 0
.Image.Top = 0
.Image.Height = Picture.Height
.Image.Width = Picture.Width
.CloseCB.Left = .ImageFrame.Width + 20
.Width = .ImageFrame.Width + 120
End With
Else
MsgBox Picture.PicFormatErrorMessage, vbCritical, "Error"
End If
End Sub
Private Sub CloseCB_Click()
Me.Hide
Unload Me
End Sub
Origineel gepost door cow18
Berichtenregels
