Sub a()
'ThisDrawing.SendCommand "_Circle 2,2,0 4 " & vbCr
ThisDrawing.ModelSpace.Layout.ConfigName = "Microsoft Office Document Image Writer"
'ThisDrawing.ModelSpace.Layout.ConfigName = "Epson LQ-1600KII"
ThisDrawing.ModelSpace.Layout.CanonicalMediaName = "A5"
'ThisDrawing.SendCommand "_Circle 2,2,0 4 " & vbCr
ThisDrawing.ModelSpace.Layout.ConfigName = "Microsoft Office Document Image Writer"
'ThisDrawing.ModelSpace.Layout.ConfigName = "Epson LQ-1600KII"
ThisDrawing.ModelSpace.Layout.CanonicalMediaName = "A5"
ThisDrawing.SendCommand "pagesetup" & vbCr
End Sub
Public Sub OpenDialog()
Dim fileName As String
ThisDrawing.SendCommand "(setvar " & """users1""" & "(getfiled " & """Select a DWG File""" & """c:/program files/acad2000/""" & """dwg""" & "8)) "
fileName = ThisDrawing.GetVariable("users1")
MsgBox "You have selected " & fileName & "!!!", , "File Message"
End Sub
Dim fileName As String
ThisDrawing.SendCommand "(setvar " & """users1""" & "(getfiled " & """Select a DWG File""" & """c:/program files/acad2000/""" & """dwg""" & "8)) "
fileName = ThisDrawing.GetVariable("users1")
MsgBox "You have selected " & fileName & "!!!", , "File Message"
End Sub
Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, "G:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Sub
红色部分代码放在单独的模块中
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
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
调用代码
Sub t()
Dim ofn As OPENFILENAME
Dim rtn As String
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Application.hWnd
'ofn.hInstance = Application.hInstance
ofn.lpstrFilter = "XML Files (*.xml)" & Chr(0) & "*.xml" & Chr(0)
ofn.lpstrFile = Space(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = "C:"
ofn.lpstrTitle = "打开文件"
ofn.flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST //' 6148
rtn = GetOpenFileName(ofn)
If rtn >= 1 Then
MsgBox ofn.lpstrFile
Else
MsgBox "Cancel Was Pressed"
End If
End Sub
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
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
调用代码
Sub t()
Dim ofn As OPENFILENAME
Dim rtn As String
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Application.hWnd
'ofn.hInstance = Application.hInstance
ofn.lpstrFilter = "XML Files (*.xml)" & Chr(0) & "*.xml" & Chr(0)
ofn.lpstrFile = Space(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = "C:"
ofn.lpstrTitle = "打开文件"
ofn.flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST //' 6148
rtn = GetOpenFileName(ofn)
If rtn >= 1 Then
MsgBox ofn.lpstrFile
Else
MsgBox "Cancel Was Pressed"
End If
End Sub
[原创]-[CAD/VBA]批量打印
打印图纸,不折不扣的体力活。最多一次打了600多张图,打印机都因"体力不支"中途休息了几次,如果不是用程序批打,估计我也得累个半死。
下面贴出打印过程的代码,加个for循环就可以批打了。简单说明一下打印函数
PrinterName - 打印机名称
Styles - 样式表名称
MediaName - 纸张大小
Copies - 打印份数
AutoMedia - 自动纸张开关
AutoRotate - 自动旋转,纵向/横向
AutoClose - 打印完毕关闭文档
AutoFrame - 自动判断图框,主要针对图框为块的情形
打印过程并没有提供全部的AUTO CAD打印选项,因为我一般用不到,比如"打印偏移"、"打印到文件"我从来不用的,如果需要可以添加进去。
程序会根据指定块名查找图框,也可以根据块的纵横比例自动判断是否为图框,然后按块打印,一张图纸中允许有多个图框;
对于编组(Group)形式的图框,指定编组名即可
如果没有找到任何图框块或编组时,按图纸范围打印
另外,打印时会先预览,然后由用户选择是否打印,避免打错。
Call PlotFunction("SHARP AR-M256", "", "A3", 1, True, True, False, True)
End Sub
Sub Plot2PDF()
Call PlotFunction("pdfFactory Pro", "acad.ctb", "", 1, True, True, False, True)
End Sub
Sub PlotA4()
Call PlotFunction("SHARP AR-M256", "acad.ctb", "A4", 1, False, True, False, True)
End Sub
'快速打印/批量打印
Public Sub PlotFunction(PrinterName As String, Styles As String, MediaName As String, Copies As Integer, _
AutoMedia As Boolean, AutoRotate As Boolean, AutoClose As Boolean, AutoFrame As Boolean)
On Error Resume Next
Dim ptMin As Variant, ptMax As Variant
Dim Ent As AcadEntity
Dim PlotCount As Integer
Set objDoc = ThisDrawing.Application.ActiveDocument
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
ThisDrawing.Application.ZoomExtents
' 设置打印机
If Not Trim(PrinterName) = "" Then
objLayout.ConfigName = PrinterName
Else
Exit Sub
End If
' 设置打印样式表
If Not Trim(Styles) = "" Then
objLayout.StyleSheet = Styles
Else
objLayout.StyleSheet = "acad.ctb"
End If
' 设置图纸尺寸
If AutoMedia Then
objLayout.CanonicalMediaName = "A3"
Else
If Not Trim(MediaName) = "" Then
objLayout.CanonicalMediaName = MediaName
Else
objLayout.CanonicalMediaName = "A3"
End If
End If
' 设置图纸单位
objLayout.PaperUnits = acMillimeters
'objLayout.PaperUnits = acInches
' 设置默认图纸打印方向
'objLayout.PlotRotation = ac0degrees '纵向
'objLayout.PlotRotation = ac180degrees
objLayout.PlotRotation = ac90degrees '横向
'objLayout.PlotRotation = ac270degrees
' 设置图纸打印比例
objLayout.StandardScale = acScaleToFit
objLayout.UseStandardScale = True '使用标准打印比例
'objLayout.UseStandardScale = False '使用自定义打印比例
' 设置自定义打印比例
'objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value
' 设置图纸是否居中打印
objLayout.CenterPlot = True
' 打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
' 设置是否应用打印样式
objLayout.PlotWithPlotStyles = True
' 打印时隐藏图纸空间对象
objLayout.PlotHidden = False
' 设置图纸打印份数
If Copies >= 1 Then
objPlot.NumberOfCopies = CInt(Copies)
Else
objPlot.NumberOfCopies = 1
End If
' 将打印错误报告切换为静默错误模式,以便不间断地执行打印任务
objPlot.QuietErrorMode = True
' 重新生成当前图形
objDoc.Regen acAllViewports
' 设置前台打印,使打印任务按打印顺序依次发送到打印机
objDoc.SetVariable "BACKGROUNDPLOT", 0
PlotCount = 0 '打印计数
For Each Ent In objDoc.ModelSpace
If TypeOf Ent Is AcadBlockReference Then
If IsFrame(Ent, AutoFrame) = True And objDoc.Blocks(Ent.Name).count > 0 Then
Ent.GetBoundingBox ptMin, ptMax
Debug.Print Ent.Name & "--" & objDoc.Blocks(Ent.Name).count
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
objLayout.PlotType = acWindow
If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) Then
If AutoMedia Then objLayout.CanonicalMediaName = "A4"
If AutoRotate Then objLayout.PlotRotation = ac0degrees
End If
' 完全预览并提示打印
objPlot.DisplayPlotPreview acFullPreview
UserSel = MsgBox("是否打印预览? " & Chr(13) & Chr(13) & "打印到:" & objLayout.ConfigName & _
" 大小:" & objLayout.CanonicalMediaName & " 方式:acWindow(" & objLayout.PlotType & ") " & _
Chr(13) & Chr(13) & "选择[取消]退出程序!", vbYesNoCancel, "打印选项")
If UserSel = vbYes Then
objPlot.PlotToDevice objLayout.ConfigName
PlotCount = PlotCount + 1
ElseIf UserSel = vbCancel Then
Exit For
End If
End If
End If
Next Ent
' 图框为编组(Group)对象时
Dim FrmGrp As AcadGroup
Dim TptMin, TptMax As Variant
' 按编组名称查找图框编组对象
For Each FrmGrp In ThisDrawing.Groups
If IsFrame(FrmGrp, False) And FrmGrp.count > 0 Then
Debug.Print FrmGrp.Name & " [Items]:" & FrmGrp.count & "----group"
' 得到图框边界点坐标
FrmGrp.Item(0).GetBoundingBox ptMin, ptMax
For i = 1 To FrmGrp.count - 1
FrmGrp.Item(i).GetBoundingBox TptMin, TptMax
ReDim Preserve TptMin(0 To 1)
ReDim Preserve TptMax(0 To 1)
For j = 0 To 1
If TptMin(j) < ptMin(j) Then
ptMin(j) = TptMin(j)
End If
If TptMax(j) > ptMax(j) Then
ptMax(j) = TptMax(j)
End If
Next j
i = i + 1
Next
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
objLayout.PlotType = acWindow
If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) Then
If AutoMedia Then objLayout.CanonicalMediaName = "A4"
If AutoRotate Then objLayout.PlotRotation = ac0degrees
End If
' 完全预览并提示打印
objPlot.DisplayPlotPreview acFullPreview
UserSel = MsgBox("是否打印预览? " & Chr(13) & Chr(13) & "打印到:" & objLayout.ConfigName & _
" 大小:" & objLayout.CanonicalMediaName & " 方式:acWindow(" & objLayout.PlotType & ") " & _
Chr(13) & Chr(13) & "选择[取消]退出程序!", vbYesNoCancel, "打印选项")
If UserSel = vbYes Then
PlotCount = PlotCount + 1
objPlot.PlotToDevice objLayout.ConfigName
ElseIf UserSel = vbCancel Then
Exit For
End If
End If
Next FrmGrp
' 没有找到图框时按范围打印
If PlotCount = 0 And objDoc.ModelSpace.count > 0 Then
ptMax = ThisDrawing.GetVariable("EXTMAX")
ptMin = ThisDrawing.GetVariable("EXTMIN")
' 图形范围内无实体则退出
If ptMax(0) = ptMin(0) Or ptMax(1) = ptMin(1) Then
Exit Sub
End If
' 设置范围打印
objLayout.PlotType = acExtents
' 对纵向的图纸设置
If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) Then
If AutoMedia Then objLayout.CanonicalMediaName = "A4"
If AutoRotate Then objLayout.PlotRotation = ac0degrees
End If
' 完全预览并提示打印
objPlot.DisplayPlotPreview acFullPreview
UserSel = MsgBox("是否打印预览? " & Chr(13) & Chr(13) & "打印到:" & objLayout.ConfigName & _
" 大小:" & objLayout.CanonicalMediaName & " 方式:acExtents(" & objLayout.PlotType & ") " & _
Chr(13) & Chr(13) & "选择[取消]退出程序!", vbYesNoCancel, "打印选项")
If UserSel = vbYes Then
objPlot.PlotToDevice objLayout.ConfigName
ElseIf UserSel = vbCancel Then
Exit Sub
End If
End If
' 关闭文档 False 为不保存修改
If AutoClose Then objDoc.Close False, ThisDrawing.Name
End Sub
Public Function IsFrame(entobj As Object, AutoMode As Boolean) As Boolean '判断是否为图框
On Error Resume Next
IsFrame = False
Dim i As Integer
Dim FrmNameList As Variant
FrmNameList = "blkFrame,A1,A2,A3,A4,PC_PAPER_DIC" '图框块、编组名列表
FrmNameList = Split(FrmNameList, ",")
For i = 0 To UBound(FrmNameList)
If entobj.Name = FrmNameList(i) Then
IsFrame = True
Exit For
End If
Next
'块名不符时由大小比例判断是否为图框(可能会误判,不过几率不高)
If IsFrame = False And AutoMode And entobj.ObjectName = "AcDbBlockReference" Then
entobj.GetBoundingBox ptMin, ptMax
Debug.Print ptMin(0) & "--" & ptMax(0)
If Abs((ptMax(1) - ptMin(1)) / (ptMax(0) - ptMin(0)) - 1.414) < 0.01 Or Abs((ptMax(1) - ptMin(1)) / (ptMax(0) - ptMin(0)) - 0.707) < 0.01 Then
IsFrame = True
End If
End If
End Function
INI文件读写VBA代码
Option Explicit
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpString As Any, _
ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpString As Any, _
ByVal lpFileName As String) As Long
Public Function ReadFromIni(ByVal IniFile As String, ByVal Section As String, ByVal Key As String, ByVal DefaultValue As String) As String
Dim strRtn As String
strRtn = Space(256)
Dim lngRtn As Long
lngRtn = GetPrivateProfileString(Section, Key, DefaultValue, strRtn, 255, IniFile)
If lngRtn > 0 Then
strRtn = Trim(strRtn)
ReadFromIni = Mid(strRtn, 1, Len(strRtn) - 1)
Else
ReadFromIni = DefaultValue
End If
Dim strRtn As String
strRtn = Space(256)
Dim lngRtn As Long
lngRtn = GetPrivateProfileString(Section, Key, DefaultValue, strRtn, 255, IniFile)
If lngRtn > 0 Then
strRtn = Trim(strRtn)
ReadFromIni = Mid(strRtn, 1, Len(strRtn) - 1)
Else
ReadFromIni = DefaultValue
End If
End Function
Public Sub WriteIntoIni(ByVal IniFile As String, ByVal Section As String, ByVal Key As String, ByVal Value As String)
Dim lngRtn As Long
lngRtn = WritePrivateProfileString(Section, Key, Value, IniFile)
If lngRtn > 0 Then
Else
Call Err.Raise(-1, "IniFileUtil.WriteIntoIni", "Failed to write")
End If
Dim lngRtn As Long
lngRtn = WritePrivateProfileString(Section, Key, Value, IniFile)
If lngRtn > 0 Then
Else
Call Err.Raise(-1, "IniFileUtil.WriteIntoIni", "Failed to write")
End If
End Sub
以下代码简单演示如何使用上述ReadFromIni、WriteIntoIni两个函数
Option Explicit
Public Sub Main()
On Error GoTo Err_Handling
Dim strIniFile As String
strIniFile = ActiveWorkbook.Path & "\example.ini"
strIniFile = ActiveWorkbook.Path & "\example.ini"
Dim strSection As String
strSection = "Application"
Dim strKey As String
strKey = "Version"
Dim strValue As String
strValue = "1.0.30"
Call IniUtil.WriteIntoIni(strIniFile, strSection, strKey, strValue)
strValue = IniUtil.ReadFromIni(strIniFile, strSection, strKey, "")
Call MsgBox("Version = " & strValue, vbInformation + vbOKOnly, ET.ActiveWorkbook.Name)
Exit_Door:
Exit Sub
Err_Handling:
Call MsgBox(Err.Number & "-" & Err.Description, vbExclamation + vbOKOnly, ET.ActiveWorkbook.Name)
Resume Exit_Door
strSection = "Application"
Dim strKey As String
strKey = "Version"
Dim strValue As String
strValue = "1.0.30"
Call IniUtil.WriteIntoIni(strIniFile, strSection, strKey, strValue)
strValue = IniUtil.ReadFromIni(strIniFile, strSection, strKey, "")
Call MsgBox("Version = " & strValue, vbInformation + vbOKOnly, ET.ActiveWorkbook.Name)
Exit_Door:
Exit Sub
Err_Handling:
Call MsgBox(Err.Number & "-" & Err.Description, vbExclamation + vbOKOnly, ET.ActiveWorkbook.Name)
Resume Exit_Door
Come from http://www.dzwebs.net Article Url??http://www.dzwebs.net/2071.html
Sub t()
Dim ofn As OPENFILENAME
Dim rtn As String
Dim uFlag
Dim OpenFiles As String
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Dim ofn As OPENFILENAME
Dim rtn As String
Dim uFlag
Dim OpenFiles As String
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
uFlag = 1
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Application.hwnd
'ofn.hInstance = Application.hInstance
ofn.lpstrFilter = "XML Files (*.dwg)" & Chr(0) & "*.dwg" & Chr(0)
ofn.lpstrFile = Space(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = "C:"
ofn.lpstrTitle = "打开文件"
ofn.flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST
'uFlag = IIf(uFlag = 1, OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST, OFN_EXPLORER Or OFN_FILEMUSTEXIST)
'ofn.flags = uFlag
rtn = GetOpenFileName(ofn)
OpenFiles = IIf(rtn > 0, ofn.lpstrFile, "")
OpenFiles = IIf(rtn > 0, ofn.lpstrFile, "")
Dim FileNames() As String
FileNames() = Split(OpenFiles, vbNullChar)
If UBound(FileNames()) < 3 Then
ReDim sFileName(0)
sFileName(0) = FileNames(0) '如果只是选了一个
Dim GetFileNames As Integer
GetFileName = 0
Else
Dim m As Integer
GetFileNames = UBound(FileNames) - 3
ReDim sFileName(0 To GetFileNames)
For m = 0 To GetFileNames
sFileName(m) = IIf(Right(FileNames(0), 1) = "\", FileNames(0) + FileNames(m + 1), FileNames(0) + "\" + FileNames(m + 1))
Debug.Print sFileName(i)
FileNames() = Split(OpenFiles, vbNullChar)
If UBound(FileNames()) < 3 Then
ReDim sFileName(0)
sFileName(0) = FileNames(0) '如果只是选了一个
Dim GetFileNames As Integer
GetFileName = 0
Else
Dim m As Integer
GetFileNames = UBound(FileNames) - 3
ReDim sFileName(0 To GetFileNames)
For m = 0 To GetFileNames
sFileName(m) = IIf(Right(FileNames(0), 1) = "\", FileNames(0) + FileNames(m + 1), FileNames(0) + "\" + FileNames(m + 1))
Debug.Print sFileName(i)
Next
End If
End If
If rtn >= 1 Then
MsgBox ofn.lpstrFile
Else
MsgBox "Cancel Was Pressed"
End If
End Sub
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
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