[已解决]如何保存窗体事的图片到指定文件夹中？？？

danysy

说明：1.点击附件中“保存窗体图片”按钮出现窗体
         2.窗体上有3个控件：文本框PN，图片image1，命令按钮cmdSave

要求：如何在点窗体上“保存图片”按钮时把图片按文件名为PN（就是文本框的名称,可以随意输入内容) 保存到同目录下的“产品图片”文件夹中 ？？？

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-11-17 15:43

1. Private Sub cmdSave_Click()
   
2.     Dim strPath$, strFilename$
   
3.    
   
4.     If Len(Me.PN.Text) = 0 Then
   
5.         MsgBox "PN为空"
   
6.         Exit Sub
   
7.     End If
   
8.    
   
9.     If Me.Image1.Picture Is Nothing Then
   
10.         MsgBox "图形控件中无加载图形"
    
11.         Exit Sub
    
12.     End If
    
13.    
    
14.    
    
15.     On Error Resume Next
    
16.    
    
17.     strPath = ThisWorkbook.Path & Application.PathSeparator & "产品图片" & Application.PathSeparator
    
18.     strFilename = Me.PN.Text & ".bmp"
    
19.     MkDir strPath
    
20.    
    
21.     If Len(Dir(strPath & strFilename)) Then
    
22.         If MsgBox(prompt:=" 当前 产品图片 下已经存在 " & strFilename, Buttons:=vbYesNo + vbInformation, Title:="是否覆盖文件") = vbNo Then
    
23.             Me.PN.SetFocus
    
24.             Exit Sub
    
25.         End If
    
26.     End If
    
27.    
    
28.     On Error GoTo ErrorHandler
    
29.    
    
30.     SavePicture Me.Image1.Picture, strPath & Me.PN.Text & ".bmp"
    
31.     MsgBox "导出完成"
    
32.     Exit Sub
    
33.    
    
34. ErrorHandler:
    
35.     MsgBox Err.Number & vbNewLine & Err.Description
    
36. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

Sub SavePicture(Picture As IPictureDisp, filename As String)
    stdole.StdFunctions 的成员
    Saves a picture to a file

hwc2ycy

1. Private Sub cmdSave_Click()
   
2.     If Len(Me.PN.Text) = 0 Then
   
3.         MsgBox "PN为空"
   
4.         Exit Sub
   
5.     End If
   
6.     Dim strPath$
   
7.     On Error Resume Next
   
8.     strPath = ThisWorkbook.Path & Application.PathSeparator & "产品图片" & Application.PathSeparator
   
9.     MkDir strPath
   
10.     On Error GoTo ErrorHandler
    
11.    
    
12.     SavePicture Me.Image1.Picture, strPath & Me.PN.Text & ".bmp"
    
13.     MsgBox "导出完成"
    
14.     Exit Sub
    
15. ErrorHandler:
    
16.     MsgBox Err.Number & vbNewLine & Err.Description
    
17. End Sub
    

复制代码

hwc2ycy

没有考虑文件覆盖的情况，没有考虑图形控件中是否加载有图形的情况。

hwc2ycy

1. Private Sub cmdSave_Click()
   
2.     Dim strPath$, strFilename$
   
3.    
   
4.     If Len(Me.PN.Text) = 0 Then
   
5.         MsgBox "PN为空"
   
6.         Exit Sub
   
7.     End If
   
8.    
   
9.     If Me.Image1.Picture Is Nothing Then
   
10.         MsgBox "图形控件中无加载图形"
    
11.         Exit Sub
    
12.     End If
    
13.    
    
14.    
    
15.     On Error Resume Next
    
16.    
    
17.     strPath = ThisWorkbook.Path & Application.PathSeparator & "产品图片" & Application.PathSeparator
    
18.     strFilename = Me.PN.Text & ".bmp"
    
19.     MkDir strPath
    
20.    
    
21.     If Len(Dir(strPath & strFilename)) Then
    
22.         If MsgBox(prompt:=" 当前 产品图片 下已经存在 " & strFilename, Buttons:=vbYesNo + vbInformation, Title:="是否覆盖文件") = vbNo Then
    
23.             Me.PN.SetFocus
    
24.             Exit Sub
    
25.         End If
    
26.     End If
    
27.    
    
28.     On Error GoTo ErrorHandler
    
29.    
    
30.     SavePicture Me.Image1.Picture, strPath & Me.PN.Text & ".bmp"
    
31.     MsgBox "导出完成"
    
32.     Exit Sub
    
33.    
    
34. ErrorHandler:
    
35.     MsgBox Err.Number & vbNewLine & Err.Description
    
36. End Sub
    

复制代码

danysy

hwc2ycy 发表于 2013-11-17 15:43

hwc2ycy老师，

谢谢您的帮忙，您的代码能满足我的要求，谢谢