Helpmij.nl
Helpmij.nl
Helpmij.nl

Quote

Weergeven resultaten 1 tot 5 van 5

Onderwerp: Range to Image

  1. #1
    Junior Member
    Geregistreerd
    8 juli 2012
    Vraag is opgelost

    Range to Image

    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
    Bijgevoegde bestanden Bijgevoegde bestanden
    Laatst aangepast door Magoo : 20 januari 2021 om 22:23

  2. #2
    Tera Honourable Senior Member
    Verenigingslid
    OctaFish's avatar
    Geregistreerd
    6 februari 2009
    Locatie
    Rotterdam
    *knip* het staat nu op de juiste plaats.
    Laatst aangepast door puppie : 21 januari 2021 om 16:50
    Gebruik de QUOTE knop alleen als je iets wit citeren.
    Op deze pagina kun je zien hoe je met TAGS werkt.

  3. #3
    Giga Senior cow18's avatar
    Geregistreerd
    24 mei 2008
    Locatie
    Alveringem, België
    mooie toepassing !
    Mr. Magoo, long time no see, still alive and kicking !?!

  4. #4
    Junior Member
    Geregistreerd
    8 juli 2012
    Quote Origineel gepost door cow18 Bekijk Bericht
    mooie toepassing !
    Mr. Magoo, long time no see, still alive and kicking !?!
    Tja op forums ben ik niet meer heel actief sinds Worksheet nl niet meer bestaat, maar programmeer nog wel eens, en ik dacht dit is een mooi voorbeeld waar meer mensen wat aan hebben :-)

  5. #5
    Hoofdmoderator
    Verenigingslid
    puppie's avatar
    Geregistreerd
    19 maart 2003
    Locatie
    Enschede
    Voorbeeld verplaatst naar de voorbeelden sectie.

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl

Regels
Help

Helpmij.nl en business

Partners
Sponsoren