田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



搞不好,房子是会整体倒塌的,有例为证。 在VB中通过相对路径引用标准DLL
未知 在VBA中使用打开和保持对话框   [ 日期:2009-07-02 ]   [ 来自:本站原创 ]  HTML
Option Explicit

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
'private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_EXPLORER = &H80000
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHOWHELP = &H10
Private Const OFS_MAXPATHNAME = 128

Private Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS
Private Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_OVERWRITEPROMPT Or OFN_HIDEREADONLY
Private Const OFS_MULTIFILE_OPEN_FLAGS = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_LONGNAMES Or OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS

Private Type OPENFILENAME
nStructSize As Long
hwndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nCustFilterSize As Long
nFilterIndex As Long
sFile As String
nFileSize As Long
sFileTitle As String
nTitleSize As Long
sInitDir As String
sDlgTitle As String
flags As Long
nFileOffset As Integer
nFileExt As Integer
sDefFileExt As String
nCustDataSize As Long
fnHook As Long
sTemplateName As String
End Type

Private Llama As OPENFILENAME
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private MyHwnd As Long ' hwnd of MY app


' +--------------------------------------------------------------------+
' | -= Main sub to call File SAVE Dialog =- |
' | |
' | Parameters: FileName$ is a variable that the name of the SAVED |
' | file name is returned in. You do NOT have to pass |
' | a filename to this routine, one is returned. Note |
' | that the Win API checks for, and prompts, if the |
' | filename already exists. |
' | |
' | FileExt$ is the file extension name you wish the |
' | Dialog box to use, for default extension, file |
' | listings, and availablity innthe drop-down "file |
' | type" box. |
' | |
' | FileDesc$ is a descriptive name for the File Name |
' | Extension, used to describe the filetype in the drop |
' | down type box. |
' | |
' | DlgTitle$ is the name of the caption on the Dialog |
' | |
' | |
' +--------------------------------------------------------------------+
Private Sub SaveFile(hwnd As Long, Filename$, FileExt$, FileDesc$, DlgTitle$)

Dim lngGo As Long
Dim lngHwnd As Long
Dim strCurName As String
Dim strNewName As String

On Error GoTo Err_Control
strCurName = Filename$
lngHwnd = hwnd
Filename$ = vbdShowSave(lngHwnd, strCurName, FileExt$, FileDesc$, DlgTitle$)

Exit Sub
Err_Control:
'Just get out, to many things to account for
MsgBox Err.Description, vbCritical, "Too many errors, aborting"
End Sub


' +--------------------------------------------------------------------+
' | -= Main sub to call File OPEN Dialog =- |
' | |
' | Parameters: FileName$ is a variable that the name of the SAVED |
' | file name is returned in. You do NOT have to pass |
' | a filename to this routine, one is returned. |
' | |
' | FileExt$ is the file extension name you wish the |
' | Dialog box to use, for default extension, file |
' | listings, and availablity innthe drop-down "file |
' | type" box. |
' | |
' | FileDesc$ is a descriptive name for the File Name |
' | Extension, used to describe the filetype in the drop |
' | down type box. |
' | |
' | |
' | DlgTitle$ is the name of the caption on the Dialog |
' | |
' | |
' +--------------------------------------------------------------------+
Private Sub FileOpen(hwnd As Long, Filename$, FileExt$, FileDesc$, DlgTitle$)

Dim lngGo As Long
Dim lngHwnd As Long
Dim strCurName As String
Dim strNewName As String

On Error GoTo Err_Control
strCurName = Filename$

lngHwnd = hwnd
strNewName = vbdShowOpen(lngHwnd, strCurName, FileExt$, FileDesc$, DlgTitle$)
Filename$ = strNewName

Exit Sub
Err_Control:
'Just get out, to many things to account for
MsgBox Err.Description, vbCritical, "Too many errors, aborting"
End Sub

' +---------------------------------------------------------------+
' | Interface from the "OpenFile" routine to the Windows API |
' +---------------------------------------------------------------+
Private Function vbdShowOpen(lngHwnd As Long, strDwgName As String, FileExt$, FileDesc$, DlgTitle$) As Variant

Dim lngReturn As Long, ShortSize As Long
Dim LongName As String, shortName As String, strFill As String
Dim strDblSpace As String, strFilter As String

strFill = Chr(0): strDblSpace = strFill & strFill
Llama.nStructSize = Len(Llama)
Llama.hwndOwner = lngHwnd

'This section is for the filter drop down list
strFilter = FileDesc$ & strFill & FileExt$ & strFill
strFilter = strFilter & "All Files" & strFill & "*.*" & strDblSpace
Llama.sFilter = strFilter
'This is the default information for the dialog
Llama.sFile = strDwgName & Space$(1024) & strFill
Llama.nFileSize = Len(Llama.sFile)
Llama.sDefFileExt = FileExt$

Llama.sFileTitle = Space(512)
Llama.nTitleSize = Len(Llama.sFileTitle)
Llama.sInitDir = CurDir
Llama.sDlgTitle = DlgTitle$

' use below to call open dialog
Llama.flags = OFS_FILE_OPEN_FLAGS
lngReturn = GetOpenFileName(Llama)

If lngReturn Then
vbdShowOpen = Llama.sFile
End If

End Function


' +---------------------------------------------------------------+
' | Interface from the "SaveFile" routine to the Windows API |
' +---------------------------------------------------------------+
Private Function vbdShowSave(lngHwnd As Long, strDwgName As String, FileExt$, FileDesc$, Caption$) As String

Dim lngReturn As Long, ShortSize As Long
Dim LongName As String, shortName As String
Dim strFill As String, strDblSpace As String, strFilter As String

strFill = Chr(0): strDblSpace = strFill & strFill
Llama.nStructSize = Len(Llama)
Llama.hwndOwner = lngHwnd

'This section is for the filter drop down list
strFilter = FileDesc$ & strFill & FileExt$ & strFill
strFilter = strFilter & "All Files" & strFill & "*.*" & strDblSpace
Llama.sFilter = strFilter
'This is the default information for the dialog
Llama.sFile = strDwgName & Space$(1024) & strFill
Llama.nFileSize = Len(Llama.sFile)
Llama.sDefFileExt = FileExt$

Llama.sFileTitle = Space(512)
Llama.nTitleSize = Len(Llama.sFileTitle)
Llama.sInitDir = CurDir
Llama.sDlgTitle = Caption$

' use below to call save dialog
Llama.flags = OFS_FILE_SAVE_FLAGS
lngReturn = GetSaveFileName(Llama)

If lngReturn Then
vbdShowSave = Llama.sFile
End If

End Function

'--- snip----------- snip----------- snip----------- snip----------- snip--------


Sub TestSaveAs()

Dim Filename As String: Filename = ThisDrawing.name
Dim FileExt As String: FileExt = "*.dwg"
Dim FileDesc As String: FileDesc = "My Acad Drawings"

SaveFile Application.hwnd, Filename, FileExt, FileDesc, "Save this sucka"

If Filename = "" Then
MsgBox "User cancelled"
Else
MsgBox "Put in code to save drawing here!" & _
vbCrLf & "Name to save:" & vbCrLf & Filename
End If

End Sub


[本日志由 tiancao1001 于 2009-07-15 03:47 PM 编辑]


暂时没有评论
发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*3=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©