在用户窗体中使用图表图像而不保存到磁盘

时间:2019-01-17 19:30:47

标签: excel vba image userform

是否可以在不首先保存到磁盘的情况下使用UserForm中的图像?保存到磁盘会大大增加代码执行时间,并会造成混乱,我必须清理。

编辑: 这是托管在我的Google云端硬盘中的示例项目: https://drive.google.com/open?id=11bko1qPI30DuN0_MtMRAmhmYYpu6lBb4

此示例应打开一个用户窗体窗口,使您可以:

  1. 选择工作表(用于演示数据)
  2. 在单元格中生成一些随机数
  3. 从这些单元格创建图像
  4. 将它们保存到磁盘并将其加载到用户窗体中

' ------------------------------------------------------
' Name: multiImageTest
' Kind: Form
' Purpose: Test the time spent updating images on a UserForm
' Author: Dave
' Date: 1/18/2019
' ------------------------------------------------------

Option Explicit

Private testSheet As Worksheet
Private images As Collection
Private tempImagePath As String

' ----------------------------------------------------------------
' Procedure Name: createImg
' Purpose: Create the image control on the UserForm
' Procedure Kind: Function
' Procedure Access: Private
' Parameter image (Long): Used to name the control
' Return Type: image
' Author: Dave
' Date: 1/18/2019
' ----------------------------------------------------------------
Private Function createImg(ByVal image As Long) As MSForms.image
    ' The Id the image will use
    Dim imgId As String: imgId = "img" + CStr(image)

    ' Create the image on the UserForm
    Set createImg = Me.Controls.add("Forms.Image.1", imgId)
    With createImg
        .top = 0
        .left = ((image - 1) * 100) + 10
        .width = 100
        .height = 40
        .PictureAlignment = fmPictureAlignmentTopLeft
        .PictureSizeMode = fmPictureSizeModeZoom
        .PictureTiling = False
        .BorderStyle = fmBorderStyleSingle
        .SpecialEffect = fmSpecialEffectFlat
        .BackStyle = fmBackStyleOpaque
        .BackColor = RGB(0, 0, 0) ' black
        .BorderColor = RGB(240, 240, 240) ' almost white
    End With

    ' Create the load time label on the UserForm
    Dim lblLoadTime As MSForms.label
    Set lblLoadTime = Me.Controls.add("Forms.Label.1", imgId + "_loadTime")
    With lblLoadTime
        .top = 40
        .left = ((image - 1) * 100) + 10
        .width = 100
        .height = 15
        .caption = "..."
        .BorderStyle = fmBorderStyleSingle
        .SpecialEffect = fmSpecialEffectFlat
        .BorderColor = RGB(0, 0, 0) ' almost white
    End With
End Function

' ----------------------------------------------------------------
' Procedure Name: btnGo_Click
' Purpose: Start execution
' Procedure Kind: Sub
' Procedure Access: Private
' Author: Dave
' Date: 1/18/2019
' ----------------------------------------------------------------
Private Sub btnGo_Click()
    Set testSheet = ActiveWorkbook.Worksheets(Me.cbSheetChoice.value)
    Dim area As range: Set area = testSheet.range("A1:C3")

    ' Put some random numbers in each cell
    execute area

End Sub

' ----------------------------------------------------------------
' Procedure Name: execute
' Purpose: Do the stuff
' Procedure Kind: Sub
' Procedure Access: Private
' Parameter area (range): The area to take an image
' Author: Dave
' Date: 1/18/2019
' ----------------------------------------------------------------
Private Sub execute(ByRef area As range)
    Dim startTime As Double
    Dim secondsElapsed As Double
    Dim tmpImage As MSForms.image
    Dim lblLoadTime As Control
    Dim image As Long
    Dim row As Long
    Dim column As Long

    ' Fill in the cells with some numbers
    For image = 1 To 5
        For row = 1 To 3
            For column = 1 To 3
                ' So Rnd gives us a random number each time
                Randomize

                area.Cells(row, column).value = Rnd(10)
            Next column
        Next row

        'Remember time
        startTime = Timer

        ' Creat the image and load Time Label
        Set tmpImage = createImg(image)
        Set lblLoadTime = Me.Controls.item("img" + CStr(image) + "_loadTime")

        ' Set the picture path on the userform object
        tmpImage.Picture = LoadPicture(getFile(area, image))

        ' Add to collection
        images.add tmpImage

        ' Set the load time amount
        lblLoadTime.caption = CStr(Round(Timer - startTime, 5)) + "s"
    Next image
End Sub

' ----------------------------------------------------------------
' Procedure Name: getFile
' Purpose: Get the File path of the newly generated image
' Procedure Kind: Function
' Procedure Access: Private
' Parameter area (range): The area to create an image from
' Parameter image (Long): Used to name the file
' Return Type: String
' Author: Dave
' Date: 1/18/2019
' ----------------------------------------------------------------
Private Function getFile(ByRef area As range, ByVal image As Long) As String
    Dim fileName As String: fileName = "tempImg" + CStr(image) + ".jpg"

    ' Copy the image to the clipboard
    area.CopyPicture xlPrinter, xlPicture

    With testSheet
        .activate

        ' Create the chart object
        Dim chtObj As ChartObject
        Set chtObj = .ChartObjects.add(image * 150, 0, area.width, area.height)

        ' Name it for easy reference
        chtObj.name = fileName

        ' Resize obj to picture size (otherwise it will be skewed)
        chtObj.width = area.width
        chtObj.height = area.height

        ' Activate the chart so we can work with it, then paste the copied range
        .ChartObjects(fileName).activate

        ActiveChart.Paste

        ' Export the file
        ActiveChart.Export fileName:=tempImagePath + fileName

        ' Delete the temporary chart object
        chtObj.delete
    End With

    getFile = tempImagePath + fileName
End Function

' ----------------------------------------------------------------
' Procedure Name: UserForm_Initialize
' Purpose: Init the UserForm
' Procedure Kind: Constructor (Initialize)
' Procedure Access: Private
' Author: Dave
' Date: 1/18/2019
' ----------------------------------------------------------------
Private Sub UserForm_Initialize()
    ' Add each Worksheet name to the dropdown box
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        Me.cbSheetChoice.AddItem ws.name
    Next ws

    ' Set the default dropdown choice to the first Sheet
    Me.cbSheetChoice.ListIndex = 0

    ' Init the images collection
    Set images = New Collection

    ' Set the temporary image path
    tempImagePath = application.ActiveWorkbook.path + application.PathSeparator
    Me.lblTempImagePath.caption = tempImagePath
End Sub

0 个答案:

没有答案