登录  
 加关注
查看详情
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

用VB实现目录选择+浏览  

2007-07-05 10:43:10|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
用VB实现目录选择+浏览(调用API)
'下面调用API实现浏览、选择目录(不能新建目录)

'Common.bas************************************************************

*

Option Explicit

Public Type BrowseInfo
     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal

lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As

BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal

pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String)

As String
     
    '定义变量
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

    '初始化.....
     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With

    '调用API
     lpIDList = SHBrowseForFolder(udtBI)
    '得到返回结果    
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If
     BrowseForFolder = sPath

End Function

'**********************************************************************

****

下面在窗体中的按钮中调用

Private Sub cmdBrowse_Click()
Dim strResFolder As String

strResFolder = BrowseForFolder(hWnd, "请选择一个目录.")

If strResFolder = "" Then
    Call MsgBox("你取消了选择目录..", vbExclamation)
Else
    Call MsgBox("目录" & strResFolder & "被选择!", vbExclamation)
End If

End Sub
 

我自己的VB程序  加载commondialog 对象

Private Sub Command4_Click()
With CommonDialog1
.InitDir = App.Path
.Filter = "Excel Files(*.XLS)"
.FileName = ""
.ShowOpen
End With
End Sub


VB中使用excel
Public mysum, mycity, myregion, mygroup, myshop, mypromotion As Long

Private Sub Form_Load()

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet


Private Sub Command1_Click()

Command1.Enabled = False

Label2.Caption = Time




Label7.Caption = CommonDialog1.FileName
a = Label7.Caption

'Workbooks.Open FileName:=a

Set xlApp = CreateObject("Excel.Application")

Set xlBook = xlApp.Workbooks.Open(a)
xlApp.Visible = True
xlApp.DisplayAlerts = True

'xlApp.Visible = False
'xlApp.DisplayAlerts = False
Set xlSheet = xlBook.Worksheets("national")
xlSheet.Activate


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:="d:\City.xls"

'*****************中间过程开始




'******************中间过程结束

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:="d:\City.xls"
Workbooks.Close
Set xlApp = CreateObject("Excel.Application")
xlApp.Quit

Set xlApp = Nothing '释放EXCEL对象

Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

Label4.Caption = Time
Command1.Enabled = True

MsgBox ("结束了")

End Sub



 
  评论这张
 
阅读(1428)| 评论(0)

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2018