如何在 GetOpenFilename打开的文件夹下新建一个文件夹

szcougar

用GetOpenFilename打开了文件夹并选择了图片后 想在此的文件夹下新建一个文件夹并吧刚选择的图片移入, VBA如何实现? 谢谢

szcougar

朱荣兴 发表于 2017-7-22 12:22
问题可以解决，请上传你的附件，

谢谢, 附加已上传

cbtaja

Example:

Mdir "c:\新文件夹"

szcougar

cbtaja 发表于 2017-7-22 12:50
Example:

Mdir "c:\新文件夹"

能具体些吗? 我是要在 GetOpenFilename 语句打开的那个文件夹下新建一个文件夹并把刚选择了的图片移入

凌空一羽

Sub 批量插图()
off = Application.Version
Dim ff
mp = ThisWorkbook.Path & "\移入\"
If Dir(mp, vbDirectory) = "" Then MkDir (mp)
tr = ActiveCell.Row: tc = ActiveCell.Column



FILETOOPEN = Application.GetOpenFilename("JPG Files (*.JPG), *.JPG", , , , True)
For Each ff In FILETOOPEN
    fff = Split(ff, "\")(UBound(Split(ff, "\")))
    FileCopy ff, mp & fff
     Cells(tr, tc).Select
     
If Application.Version <> "11.0" Then
        ActiveSheet.Pictures.Insert(ff).Cut
         Cells(tr, tc).Select
        ActiveSheet.PasteSpecial Format:="图片 (JPEG)"
    Else
         ActiveSheet.Pictures.Insert(ff).Select
    End If


Cells(tr + 14, tc) = ff1
tc = tc + 60
If tc = 182 Then
tr = tr + 14
tc = 2


    End If
Next ff

    Application.CommandBars("Picture").Visible = False

End Sub

凌空一羽

遇审核，请直接看附件

cbtaja

szcougar 发表于 2017-7-22 12:54
能具体些吗? 我是要在 GetOpenFilename 语句打开的那个文件夹下新建一个文件夹并把刚选择了的图片移入

1. Sub test()
   
2. 
   
3. Dim fso As New FileSystemObject '需引用"Mircrosoft Scripting Runtime"
   
4. fl = Excel.Application.GetOpenFilename '指定文件名
   
5. If f <> False Then
   
6.     fld = fso.GetParentFolderName(fl) '获取文件夹名称（全路径)
   
7.     subfld = fld & "\新文件夹" '目标文件夹
   
8.     If Not fso.FolderExists(subfld) Then MkDir subfld '如果目标文件夹不存在则新建
   
9.     If Dir(subfld, vbDirectory) = "" Then MkDir subfld '如果目标文件夹不存在则新建
   
10.     fso.MoveFile f, subfld '移动文件
    
11. End If
    
12. 
    
13. End Sub

复制代码

szcougar

凌空一羽 发表于 2017-7-22 13:21
遇审核，请直接看附件

谢谢.  试运行了你改的这个但 新建的文件夹不是我选择图片的那个文件夹下而是excel文件所在的那个文件夹里了, 并且图片都是拷贝的而不是移动过去的. 能再改改吗?

szcougar

cbtaja 发表于 2017-7-22 13:22

我是VBA新手.
这句 fso As New FileSystemObject  编译错误  用户定义类型未定义  怎么解决? 谢谢