1,453
社区成员
发帖
与我相关
我的任务
分享VB6 CommonDialog初始路径第二次打开会失效
生成为exe后，第一次打开是X盘，但是比如我打开后选择了D盘的excel，之后打开程序就会默认跑到D盘而不是X盘，怎么把他固定下来。
以下是具体代码，操作系统是server 2012
CommonDialog1.MaxFileSize = 32767
CommonDialog1.InitDir = "X:\"
CommonDialog1.Filter = "Excel(*.xls)|*.xls"
CommonDialog1.Flags = cdlOFNExplorer
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
Erase a, b
If CommonDialog1.FileName <> "" Then
a = Split(CommonDialog1.FileName, Chr(0))
b = Split(CommonDialog1.FileTitle, Chr(0))
End If
以下是具体代码，操作系统是server 2012
CommonDialog1.MaxFileSize = 32767
CommonDialog1.InitDir = "X:\"
CommonDialog1.Filter = "Excel(*.xls)|*.xls"
CommonDialog1.Flags = cdlOFNExplorer
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
Erase a, b
If CommonDialog1.FileName <> "" Then
a = Split(CommonDialog1.FileName, Chr(0))
b = Split(CommonDialog1.FileTitle, Chr(0))
End If
...全文
请发表友善的回复…
发表回复
舉杯邀明月 2018-06-16
- 打赏
- 举报
我试了一下你这个“注释掉”的函数，主要有两个问题：
1. 缺少 SmBrowFolder 这个枚举类型的定义。
2. 缺少 GetReturnType() 这个函数定义。
我把函数参数 FolderID 类型改为 Long 类型、 再把.ulFlags = GetReturnType() 改为 .ulFlags = 0
调用时， FolderID参数值传13或0，就可以了。
不过，我以前就有这个“选择文件夹”的封装函数，要比你的这段代码简单些。
脆皮大雪糕 2018-06-15
- 打赏
- 举报
第二截，其中有一个函数被我整体注释掉了，应该是当时有点啥问题，因为没用到于是懒得查问题直接注释掉。
'
'文件夹选择对话框
'函数:SaveFile
'参数:Title 设置对话框的标签.
' hWnd 调用此函数的HWND
' FolderID SmBrowFolder枚举(默认:我的电脑).
'返回值:String 文件夹路径.
'例子：
'Public Function GetFolder(Optional Title As String, _
' Optional hWnd As Long, _
' Optional FolderID As SmBrowFolder = MyComputer) As String
' Dim Bi As BROWSEINFO
' Dim Pidl As Long
' Dim Folder As String
' Dim IDL As ITEMIDLIST
' Dim nFolder As Long
' Dim ReturnFol As String
' Dim Fid As Integer
'
' Fid = FolderID
' Folder = String$(255, Chr$(0))
' With Bi
' .hOwner = hWnd
' nFolder = GetFolderValue(Fid)
' If SHGetSpecialFolderLocation(ByVal hWnd, ByVal nFolder, IDL) = NoError Then
' .pidlRoot = IDL.mkid.cb
' End If
' .pszDisplayName = String$(MAX_PATH, Fid)
'
' If Len(Title) > 0 Then
' .lpszTitle = Title & Chr$(0)
' Else
' .lpszTitle = "请选择文件夹:" & Chr$(0)
' End If
'
' .ulFlags = GetReturnType()
' End With
'
' Pidl = SHBrowseForFolder(Bi)
' '/返回所选的文件夹路径
' If SHGetPathFromIDList(ByVal Pidl, ByVal Folder) Then
' ReturnFol = Left$(Folder, InStr(Folder, Chr$(0)) - 1)
' If Right$(Trim$(ReturnFol), 1) <> "/" Then ReturnFol = ReturnFol & "/"
' GetFolder = ReturnFol
' Else
' GetFolder = ""
' End If
'End Function
'
'文件保存对话框
'函数:SaveFile
'参数:WinHwnd 调用此函数的HWND
' BoxLabel 设置对话框的标签.
' StartPath 设置初始化路径.
' FilterStr 文件过滤.
' Flag 标志.(参考MSDN)
'返回值:String 文件名.
'例子：
Public Function SaveFile(WinHwnd As Long, _
Optional BoxLabel As String = "", _
Optional StartPath As String = "", _
Optional FilterStr = "*.*|*.*", _
Optional Flag As Variant = &H4 Or &H200000) As String
Dim rc As Long
Dim pOpenfilename As OPENFILENAME
Dim Fstr1() As String
Dim Fstr As String
Dim i As Long
Const MAX_Buffer_LENGTH = 256
On Error Resume Next
If Len(Trim$(StartPath)) > 0 Then
If Right$(StartPath, 1) <> "/" Then StartPath = StartPath & "/"
If Dir$(StartPath, vbDirectory + vbHidden) = "" Then
StartPath = App.Path
End If
Else
StartPath = App.Path
End If
If Len(Trim$(FilterStr)) = 0 Then
Fstr = "*.*|*.*"
End If
Fstr1 = Split(FilterStr, "|")
For i = 0 To UBound(Fstr1)
Fstr = Fstr & Fstr1(i) & vbNullChar
Next
'/--------------------------------------------------
With pOpenfilename
.hwndOwner = WinHwnd
.hInstance = App.hInstance
.lpstrTitle = BoxLabel
.lpstrInitialDir = StartPath
.lpstrFilter = Fstr
.nFilterIndex = 1
.lpstrDefExt = vbNullChar & vbNullChar
.lpstrFile = String(MAX_Buffer_LENGTH, 0)
.nMaxFile = MAX_Buffer_LENGTH - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = MAX_Buffer_LENGTH
.lStructSize = Len(pOpenfilename)
.flags = Flag
End With
rc = GetSaveFileName(pOpenfilename)
If rc Then
SaveFile = Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile)
Else
SaveFile = ""
End If
End Function
'
'文件打开对话框
'函数:OpenFile
'参数:WinHwnd 调用此函数的HWND
' BoxLabel 设置对话框的标签.
' StartPath 设置初始化路径.
' FilterStr 文件过滤.
' Flag 标志.(参考MSDN)
'返回值:String 文件名.
'例子：
Public Function MyOpenFile(WinHwnd As Long, _
Optional BoxLabel As String = "", _
Optional StartPath As String = "", _
Optional FilterStr = "*.*|*.*", _
Optional Flag As Variant = &H8 Or &H200000) As String
Dim rc As Long
Dim pOpenfilename As OPENFILENAME
Dim Fstr1() As String
Dim Fstr As String
Dim i As Long
Const MAX_Buffer_LENGTH = 256
On Error Resume Next
If Len(Trim$(StartPath)) > 0 Then
If Right$(StartPath, 1) <> "/" Then StartPath = StartPath & "/"
If Dir$(StartPath, vbDirectory + vbHidden) = "" Then
StartPath = App.Path
End If
Else
StartPath = App.Path
End If
If Len(Trim$(FilterStr)) = 0 Then
Fstr = "*.*|*.*"
End If
Fstr = ""
Fstr1 = Split(FilterStr, "|")
For i = 0 To UBound(Fstr1)
Fstr = Fstr & Fstr1(i) & vbNullChar
Next
With pOpenfilename
.hwndOwner = WinHwnd
.hInstance = App.hInstance
.lpstrTitle = BoxLabel
.lpstrInitialDir = StartPath
.lpstrFilter = Fstr
.nFilterIndex = 1
.lpstrDefExt = vbNullChar & vbNullChar
.lpstrFile = String(MAX_Buffer_LENGTH, 0)
.nMaxFile = MAX_Buffer_LENGTH - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = MAX_Buffer_LENGTH
.lStructSize = Len(pOpenfilename)
.flags = Flag
End With
rc = GetOpenFileName(pOpenfilename)
If rc Then
MyOpenFile = Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile)
Else
MyOpenFile = ""
End If
End Function
'
'颜色对话框
'函数:GetColor
'参数:
'返回值:Long,用户所选择的颜色.
'例子：
Public Function GetColor() As Long
Dim rc As Long
Dim pChoosecolor As CHOOSECOLOR
Dim CustomColor() As Byte
With pChoosecolor
.hwndOwner = 0
.hInstance = App.hInstance
.lpCustColors = StrConv(CustomColor, vbUnicode)
.flags = 0
.lStructSize = Len(pChoosecolor)
End With
rc = CHOOSECOLOR(pChoosecolor)
If rc Then
GetColor = pChoosecolor.rgbResult
Else
GetColor = -1
End If
End Function
脆皮大雪糕 2018-06-15
- 打赏
- 举报
分两截贴吧
Option Explicit
Private Declare Sub CopyMem Lib "KERNEL32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Sub CopyMemByPtr Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal lpTo As Long, ByVal lpFrom As Long, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "KERNEL32" Alias "lstrlenA" (ByVal lpString As Any) As Long
'**********************************************************
''定义一个全局变量,用于保存字体的各种属性
Public Type SmFontAttr
FontName As String '字体名
FontSize As Integer '字体大小
FontBod As Boolean '是否黑体
FontItalic As Boolean '是否斜体
FontUnderLine As Boolean '是否下划线
FontStrikeou As Boolean
FontColor As Long
WinHwnd As Long
End Type
Dim M_GetFont As SmFontAttr
Private Const LF_FACESIZE = 32
Private Const MAX_PATH = 260
Private Const CF_INITTOLOGFONTSTRUCT = &H40
Private Const CF_FIXEDPITCHONLY = &H4000
Private Const CF_EFFECTS = &H100
Private Const CF_SHOWHELP = &H4
'/------------------------------------------
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'/-----------------------------------------------------------
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hdc As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
'/--------------
Private Type SHITEMID
cb As Long
abID() As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
'/------------------------------------------
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
Pidl As ITEMIDLIST) As Long
'/------------------------------------------
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hWnd As Long, ByVal dwType As Long) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChooseFont As CHOOSEFONT) As Long
'/=======显示断开网络资源对话框============
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" _
(ByVal hWnd As Long, ByVal dwType As Long) As Long
'/================================================================================
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'/结构说明: _
hOwner 调用这个对话框的窗口的句柄 _
pidlRoot 指向你希望浏览的最上面的文件夹的符列表 _
pszDisplayName 用于保存用户所选择的文件夹的显示名的缓冲区 _
lpszTitle 浏览对话框的标题 _
ulFlags 决定浏览什么的标志(见下) _
lpfn 当事件发生时对话框调用的回调函数的地址.可将它设定为NULL _
lparam 若定义了回调函数,则为传递给回调函数的值 _
iImage As Long 保存所选文件夹映像索引的缓冲区 _
ulFlags参数(见下:)
Private Const BIF_RETURNONLYFSDIRS = &H1 '仅允许浏览文件系统文件夹
Private Const BIF_DONTGOBELOWDOMAIN = &H2 '利用这个值强制用户仪在网上邻居的域级别中
Private Const BIF_STATUSTEXT = &H4 '在选择对话中显示状态栏
Private Const BIF_RETURNFSANCESTORS = &H8 '返回文件系统祖先
Private Const BIF_BROWSEFORCOMPUTER = &H1000 '允许浏览计算机
Private Const BIF_BROWSEFORPRINTER = &H2000 '允许游览打印机文件夹
'/--------------------------------------------------------------------------------
Private Function GetFolderValue(wIdx As Integer) As Long
If wIdx < 2 Then
GetFolderValue = 0
ElseIf wIdx < 12 Then
GetFolderValue = wIdx
Else
GetFolderValue = wIdx + 4
End If
End Function
脆皮大雪糕 2018-06-15
- 打赏
- 举报
想贴个模块，居然超过发帖限制
civvss 2018-06-14
- 打赏
- 举报
API怎么调用，有教程吗
civvss 2018-06-14
- 打赏
- 举报
API怎么调用，有教程吗
舉杯邀明月 2018-06-14
- 打赏
- 举报
API怎么调用，有教程吗[/quote]
要“教程”，查MSDN、或者百度啊……
给你一段简单使用的代码参考：
这只是打开“单个文件”用的，当然它也跟 CommonDialog控件一样，
只返回了选择的文件（完整路径），并没有真正“打开文件”（显然不可能执行真正的打开操作）。
Option Explicit
' -= 文件对话框 =-
Private Declare Function GetOpenFileName Lib "Comdlg32" Alias "GetOpenFileNameW" ( _
ByRef pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "Comdlg32" Alias "GetSaveFileNameW" ( _
ByRef pOpenfilename As OPENFILENAME) As Long
' * * * 打开/保存 文件API用数据类型 * * *
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As Long
lpstrCustFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As Long
nMaxFile As Long
lpstrFileTitle As Long
nMaxFileTitle As Long
lpstrInitialDir As Long
lpstrTitle As Long
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Private Function ShowOpen(ByVal Title As String, ByVal Filter As String, _
ByRef FileOpen As String) As Long
Dim OpenFN As OPENFILENAME
Dim strFilt As String
Dim strPath As String
Dim strName As String
Dim strTemp As String
strName = String$(264&, 0)
strTemp = strName
strPath = App.Path & "\" & vbNullChar
strFilt = Replace(Replace(Filter & vbNullChar, "|", vbNullChar), ",", vbNullChar)
OpenFN.lStructSize = 76& ' LenB(OpenFN)
OpenFN.hWndOwner = Me.hWnd
OpenFN.hInstance = App.hInstance
OpenFN.lpstrTitle = StrPtr(Title)
OpenFN.lpstrFilter = StrPtr(strFilt)
OpenFN.nFilterIndex = 0&
OpenFN.lpstrDefExt = 5& + StrPtr(strFilt) + InStrB(1&, Filter, "|") ' 第一种类型的扩展名
OpenFN.lpstrInitialDir = StrPtr(strPath)
OpenFN.lpstrFile = StrPtr(strName)
OpenFN.nMaxFile = 256&
OpenFN.lpstrFileTitle = StrPtr(strTemp)
OpenFN.nMaxFileTitle = 256&
OpenFN.Flags = &H180C&
If (GetOpenFileName(OpenFN)) Then
Dim p As Long
p = InStr(1&, strName, vbNullChar)
FileOpen = Left$(strName, p - 1&)
ShowOpen = vbFalse
Else
ShowOpen = vbTrue
End If
End Function
Private Sub Command1_Click()
Dim strFile As String
If (ShowOpen("打开文件", "所有文件（*.*）|*.*,", strFile)) Then Exit Sub
Call MsgBox(strFile, 64&)
End Sub脆皮大雪糕 2018-06-11
- 打赏
- 举报
我一直觉得这个控件不正常，所以我一直都是用API的
赵4老师 2018-06-11
- 打赏
- 举报
不稳定的根是Win10，我猜。
舉杯邀明月 2018-06-10
- 打赏
- 举报
我的以前写好的程序中，有“设置了路径”的，但从来没有起到过作用。
显然： 不能“重现”的那儿的情况。
再说了，你那儿一会儿这种状态、一会儿那种状态，这么“灵异”的事情，能作为“通用”方法吗！
我的是“路径以1个 \ 结尾”，就一定有效，这样的才“通用”啊。
我的是“路径以1个 \ 结尾”，就一定有效，这样的才“通用”啊。
笨狗先飞 2018-06-10
- 打赏
- 举报
代码我都贴上边了，别的参数没了，问题可以重现，新建出来的工程就这样，编译两次好了，win10+VB6mini
舉杯邀明月 2018-06-10
- 打赏
- 举报
昨天偶然想到“路径加 \ ”的问题。
然后才发现，终于能“按我的想法来设置初始路径”了。
舉杯邀明月 2018-06-10
- 打赏
- 举报
在我的这儿，这事从来没有出现过“诡异现象”。
有几个小程序，一直在“偶尔用下”，持续2、3年了吧。
有的是设置了路径的（都是app.path，非根目录，最后没带 \ 的），也有的是设置为NULL的（相当于“没设置”）
都是一样的反应：初始路径似乎由“系统记忆”来决定的。
你的 CommonDialog1.Flag 没有设置吧？（控件按不同的“对话框类型”有不同的默认值）
我的“打开文件”的是 &H1804 。
不知道你的“突然好了”，是否是改变对话框的路径后，选择某文件“打开”了呢？
如果你是“取消”的话，即使改变了路径，“系统的记忆”也不会改变的，跟“之前的”一样。
因此，如果是“取消”，有可能造成误导。
笨狗先飞 2018-06-10
- 打赏
- 举报
写一下我的测试过程
1.新建空工程，加一个CommonDialog1和一个Command1，代码如下
Private Sub Command1_Click()
CommonDialog1.InitDir = "c:\"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
Me.Caption = CommonDialog1.FileName
End Sub
Private Sub Command1_Click()
CommonDialog1.InitDir = app.path & "\"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
Me.Caption = CommonDialog1.FileName
End Sub笨狗先飞 2018-06-10
- 打赏
- 举报
我的 E:\ D:\ C:\ F:\ 都试了，在IDE中运行、编译后运行都正常。
C:盘是系统盘。
你再试试： 目录 \ 后再加个 vbNullChar
比如， CommonDialog1.InitDir = "C:\" & vbNullChar
[/quote]
诡异的现象，突然就好了，加不加\已经无所谓了，就是好的，你试试看。
舉杯邀明月 2018-06-09
- 打赏
- 举报
我的 E:\ D:\ C:\ F:\ 都试了，在IDE中运行、编译后运行都正常。
C:盘是系统盘。
你再试试： 目录 \ 后再加个 vbNullChar
比如， CommonDialog1.InitDir = "C:\" & vbNullChar
笨狗先飞 2018-06-09
- 打赏
- 举报
看来还是和api有差别，我一直用c:\在试，不行的
舉杯邀明月 2018-06-09
- 打赏
- 举报
不是Len判断的问题，根目录的时候InitDir \结尾也不起作用[/quote]
我刚才试了根目录，照样完全正常。
只要是“存在的、有效的目录，并且给定目录是以1个\结尾的”，无论是否为根目录，都是正常的。
笨狗先飞 2018-06-09
- 打赏
- 举报
不是Len判断的问题，根目录的时候InitDir \结尾也不起作用
舉杯邀明月 2018-06-09
- 打赏
- 举报
当然，“判断最后一个字符是不是 \ ”的方法，对App.Path 也同样可用。
只不过 App.Path 直接用 Len( )来判断，代码简单点，运行效率也高点。
加载更多回复（8）
