将文本框内容保存为图像文件
Saving textbox content as image file
虽然我找到了一种将位于工作表中的文本框的内容保存为图像文件(png、bmp、jpeg)的方法,但我无法为位于用户窗体中的文本框实现同样的事情。
附码returns一张空白图片。
有人能给我指出正确的方向吗?
Private Sub CommandButton1_Click()
' save textbox content as image file
Dim cht As ChartObject
Dim ActiveShape As Shape
TextBox1.Text = "12345"
' select the TextBox
TextBox1.SetFocus
' Copy selection
Selection.Copy
'
Application.ScreenUpdating = False
Worksheets("Sheet1").Activate
' paste selection into a picture shape
ActiveSheet.Pictures.Paste(link:=False).Select
Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
' Create temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add(Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, Top:=ActiveCell.Top, Height:=ActiveShape.Height)
' Format temporary chart to have a transparent background
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
' Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as image file
cht.Chart.Export Environ("USERPROFILE") & "\Desktop\" & "TextBoxImage" & ".bmp"
'Delete temporary Chart
cht.Delete
ActiveShape.Delete
Application.ScreenUpdating = True
End Sub
恐怕用户表单文本框没有必要的 CopyPicture
属性。即使对于 sheet ActiveX 文本框,Copy
也不会 return 对象图片...
所以,你可以完成你想要的,只需要使用一个技巧:在 sheet 上创建这样一个文本框克隆并使用它来导出图片:
Private Sub CommandButton1_Click()
Dim ob As OLEObject, sh As Worksheet, tb As msforms.TextBox, ch As ChartObject, pictName As String
Set sh = ActiveSheet
pictName = ThisWorkbook.path & "\TextBoxImage.jpg"
Set ob = sh.OLEObjects.Add(ClassType:="Forms.TextBox.1", link:=False, _
DisplayAsIcon:=False, left:=383.4, top:=29.4, width:=Me.TextBox1.width, height:=Me.TextBox1.height)
Set tb = ob.Object
DoEvents
With tb
.Text = Me.TextBox1.Text
.BackColor = Me.TextBox1.BackColor
.ForeColor = Me.TextBox1.ForeColor
.Font = Me.TextBox1.Font
.Font.Size = Me.TextBox1.Font.Size
End With
DoEvents
Set ch = sh.ChartObjects.Add(left:=1, _
top:=1, width:=tb.width, height:=tb.height)
tb.CopyPicture: ch.Activate: ActiveChart.Paste
ch.Chart.Export pictName, "JPEG"
ch.Delete
ob.Delete
End Sub
如有必要,可以用相同的方式复制其他一些文本框属性(粗体、斜体等)。
请测试它并发送一些反馈。
虽然我找到了一种将位于工作表中的文本框的内容保存为图像文件(png、bmp、jpeg)的方法,但我无法为位于用户窗体中的文本框实现同样的事情。 附码returns一张空白图片。 有人能给我指出正确的方向吗?
Private Sub CommandButton1_Click()
' save textbox content as image file
Dim cht As ChartObject
Dim ActiveShape As Shape
TextBox1.Text = "12345"
' select the TextBox
TextBox1.SetFocus
' Copy selection
Selection.Copy
'
Application.ScreenUpdating = False
Worksheets("Sheet1").Activate
' paste selection into a picture shape
ActiveSheet.Pictures.Paste(link:=False).Select
Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
' Create temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add(Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, Top:=ActiveCell.Top, Height:=ActiveShape.Height)
' Format temporary chart to have a transparent background
cht.ShapeRange.Fill.Visible = msoFalse
cht.ShapeRange.Line.Visible = msoFalse
' Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as image file
cht.Chart.Export Environ("USERPROFILE") & "\Desktop\" & "TextBoxImage" & ".bmp"
'Delete temporary Chart
cht.Delete
ActiveShape.Delete
Application.ScreenUpdating = True
End Sub
恐怕用户表单文本框没有必要的 CopyPicture
属性。即使对于 sheet ActiveX 文本框,Copy
也不会 return 对象图片...
所以,你可以完成你想要的,只需要使用一个技巧:在 sheet 上创建这样一个文本框克隆并使用它来导出图片:
Private Sub CommandButton1_Click()
Dim ob As OLEObject, sh As Worksheet, tb As msforms.TextBox, ch As ChartObject, pictName As String
Set sh = ActiveSheet
pictName = ThisWorkbook.path & "\TextBoxImage.jpg"
Set ob = sh.OLEObjects.Add(ClassType:="Forms.TextBox.1", link:=False, _
DisplayAsIcon:=False, left:=383.4, top:=29.4, width:=Me.TextBox1.width, height:=Me.TextBox1.height)
Set tb = ob.Object
DoEvents
With tb
.Text = Me.TextBox1.Text
.BackColor = Me.TextBox1.BackColor
.ForeColor = Me.TextBox1.ForeColor
.Font = Me.TextBox1.Font
.Font.Size = Me.TextBox1.Font.Size
End With
DoEvents
Set ch = sh.ChartObjects.Add(left:=1, _
top:=1, width:=tb.width, height:=tb.height)
tb.CopyPicture: ch.Activate: ActiveChart.Paste
ch.Chart.Export pictName, "JPEG"
ch.Delete
ob.Delete
End Sub
如有必要,可以用相同的方式复制其他一些文本框属性(粗体、斜体等)。
请测试它并发送一些反馈。