【VBA源码】由xls表格到dwg实长绘制直线文字
一、为了方便编辑，表图一致，生成的是直线+多行文字
二、不支持上下标
三、支持合并单元格，文字全部居中，表格是WPS表格。
四、使用方法：
1、输入范围时：输3.11.4.12表示第3行到第11行，第4列到第12列表格会绘制
2、想要单元格高度为10mm，宽度为20mm，文字高5mm，应该在xls文件中调整宽高
xls中行高设为10*2.8346439磅
xls中列宽设为20/2.26366字符
xls中单元格字高设为5*2.8346439
3、表格有框线的会画线，没有框的不画线
4、xls每行、每列设置值转化成的毫米数就是绘制出来表的毫米数。
5、字高按单元格的字体大小转化成的毫米数就是绘制出来的毫米数。
6、用单线字体则生成的文字绝对居中
五、效果：
六、源码
（含了一些常用函数、类）
【获取(Xl)Workbook对象（无论打开与否）】
【判断文件是否打开】
【获得工作空间】
【创建居中的多行文字】
【对话框类】
'表格成图2
Function LnCAD_DrawTableByXl2(cadDrawing As Object)
'tb前缀表示要转化的表
Dim idebug As Integer
Dim i As Integer
Dim j As Integer
Dim xlPath As String
Call Sys_GetPathByDlg(xlPath, cadDrawing.Path, "xls")
'获得工作薄
Dim gvWb As Variant
Dim lngR1 As Long
lngR1 = Xl_GetWorkbook(xlPath, gvWb)
If lngR1 < 1 Then
Exit Function
End If
'读取数据
Dim xlSh As Variant
Set xlSh = gvWb.Worksheets(1) '设置活动工作表
'获得表格范围
Dim rngStr As String '范围字符串
rngStr = cadDrawing.Utility.GetString(False, vbCrLf & "范围.号分隔<开始行.结束行.开始列.结束列>]:")
Dim rngArr As Variant
rngArr = Split(rngStr, ".")
Dim tbSRow As Integer '开始行号
Dim tbERow As Integer '结束行号
Dim tbSCol As Integer '开始列号
Dim tbECol As Integer '结束列号
tbSRow = Int(rngArr(0))
tbERow = Int(rngArr(1))
tbSCol = Int(rngArr(2))
tbECol = Int(rngArr(3))
If tbSRow > tbERow Or tbSCol > tbECol Then
MsgBox "范围值错误"
Exit Function
End If
Dim tbRowN As Integer '自然行数
Dim tbColN As Integer '自然列数
tbRowN = tbERow - tbSRow
tbColN = tbECol - tbSCol
'行高
Dim aRow As Variant
Dim tbRowHs() As Double '行高
ReDim tbRowHs(tbRowN)
For i = 0 To tbRowN
Set aRow = xlSh.Rows(tbSRow + i)
tbRowHs(i) = Format(aRow.RowHeight / 2.8346439, "0.0") '由point换算成mm，并取1位小数
Next
'列宽
Dim aCol As Variant
Dim tbColWs() As Double '列宽
ReDim tbColWs(tbColN)
For i = 0 To tbColN
Set aCol = xlSh.Columns(tbSCol + i)
tbColWs(i) = Format(aCol.ColumnWidth * 2.26366, "0.0") '字符换算成mm，并取1位小数
Next
'绘图空间
Dim wkSpace As Variant
Call LnCAD_GetWkSpace(cadDrawing, wkSpace)
'基本定义
Dim ptA(2) As Double
Dim ptB(2) As Double
Dim insPt(2) As Double
Dim textH As Double '字高
Dim aLine As Variant
Dim IsBorder As Boolean
Dim IsFirstSeg As Boolean '是否首段
Dim lineL As Double '线长
Dim aRange As Variant
Dim bRange As Variant
Dim mrgRange As Variant
Dim mrgRowNp As Integer '合并区域行数
Dim mrgRow As Integer '合并区域首行号
Dim mrgColNp As Integer '合并区域列数
Dim mrgCol As Integer '合并区域首列号
Dim iRow As Integer
Dim iCol As Integer
'Range.Borders(item)item取值：xlEdgeLeft=7,xlEdgeTop=8,xlEdgeBottom=9,xlEdgeRight=10
'拾取基点
Dim bsPt As Variant '平面基点
bsPt = cadDrawing.Utility.GetPoint(, vbCrLf & "指定平面基点:")
'画横线
'第1条横线
ptA(0) = 0
lineL = 0
IsFirstSeg = True
For i = 0 To tbColN
Set aRange = xlSh.cells(tbSRow, tbSCol + i)
IsBorder = False
If aRange.Borders(8).LineStyle <> -4142 Then
IsBorder = True
End If
If IsBorder = True Then '是框则线长增加
lineL = lineL + tbColWs(i)
End If
If IsFirstSeg = True Then '是首段则调整起点
ptA(0) = 0
If i > 0 Then
For j = 0 To i - 1
ptA(0) = ptA(0) + tbColWs(j)
Next
End If
IsFirstSeg = False
End If
If IsBorder = False Or i = tbColN Then '不是框或到达表格最后则画线
If lineL > 0 Then
ptA(0) = bsPt(0) + ptA(0)
ptA(1) = bsPt(1)
ptB(0) = ptA(0) + lineL
ptB(1) = ptA(1)
Set aLine = wkSpace.AddLine(ptA, ptB)
End If
IsFirstSeg = True
lineL = 0
End If
Next
'画下横线
For iRow = 0 To tbRowN
ptA(0) = 0
ptA(1) = 0
lineL = 0
' lineMv = 0
IsFirstSeg = True
For i = 0 To tbColN
Set aRange = xlSh.cells(tbSRow + iRow, tbSCol + i)
Set bRange = xlSh.cells(tbSRow + iRow + 1, tbSCol + i)
IsBorder = False
If aRange.Borders(9).LineStyle <> -4142 Or bRange.Borders(8).LineStyle <> -4142 Then
If aRange.MergeCells = False Then
IsBorder = True
Else
Set mrgRange = aRange.MergeArea
mrgRowNp = mrgRange.Rows.Count
mrgRow = mrgRange.Row
If tbSRow + iRow = mrgRow + mrgRowNp - 1 Then '合并区只有最后一行算下边界
IsBorder = True
End If
End If
End If
If IsBorder = True Then '是框则线长增加
lineL = lineL + tbColWs(i)
End If
If IsFirstSeg = True Then '是首段则调整起点
ptA(0) = 0
If i > 0 Then
For j = 0 To i - 1
ptA(0) = ptA(0) + tbColWs(j)
Next
End If
IsFirstSeg = False
End If
If IsBorder = False Or i = tbColN Then '不是框或到达表格最后则画线
If lineL > 0 Then
ptA(0) = bsPt(0) + ptA(0)
ptB(0) = ptA(0) + lineL
ptA(1) = 0
For j = 0 To iRow
ptA(1) = ptA(1) + tbRowHs(j)
Next
ptA(1) = bsPt(1) - ptA(1)
ptB(1) = ptA(1)
Set aLine = wkSpace.AddLine(ptA, ptB)
End If
IsFirstSeg = True
lineL = 0
End If
Next
Next
'画竖线
'第1条竖线
ptA(0) = 0
lineL = 0
IsFirstSeg = True
For i = 0 To tbRowN
Set aRange = xlSh.cells(tbSRow + i, tbSCol)
IsBorder = False
If aRange.Borders(7).LineStyle <> -4142 Then
IsBorder = True
End If
If IsBorder = True Then '是框则线长增加
lineL = lineL + tbRowHs(i)
End If
If IsFirstSeg = True Then '是首段则调整起点
ptA(1) = 0
If i > 0 Then
For j = 0 To i - 1
ptA(1) = ptA(1) + tbRowHs(j)
Next
End If
IsFirstSeg = False
End If
If IsBorder = False Or i = tbRowN Then '不是框或到达表格最后则画线
If lineL > 0 Then
ptA(0) = bsPt(0)
ptA(1) = bsPt(1) + ptA(1)
ptB(0) = ptA(0)
ptB(1) = ptA(1) - lineL
Set aLine = wkSpace.AddLine(ptA, ptB)
End If
IsFirstSeg = True
lineL = 0
End If
Next
'画右竖线
For iCol = 0 To tbColN
ptA(0) = 0
ptA(1) = 0
lineL = 0
' lineMv = 0
IsFirstSeg = True
For i = 0 To tbRowN
Set aRange = xlSh.cells(tbSRow + i, tbSCol + iCol)
Set bRange = xlSh.cells(tbSRow + i, tbSCol + iCol + 1)
IsBorder = False
If aRange.Borders(10).LineStyle <> -4142 Or bRange.Borders(7).LineStyle <> -4142 Then
If aRange.MergeCells = False Then
IsBorder = True
Else
Set mrgRange = aRange.MergeArea
mrgColNp = mrgRange.Columns.Count
mrgCol = mrgRange.Column
If tbSCol + iCol = mrgCol + mrgColNp - 1 Then '合并区只有最后一列算右边界
IsBorder = True
End If
End If
End If
If IsBorder = True Then '是框则线长增加
lineL = lineL + tbRowHs(i)
End If
If IsFirstSeg = True Then '是首段则调整起点
ptA(1) = 0
If i > 0 Then
For j = 0 To i - 1
ptA(1) = ptA(1) + tbRowHs(j)
Next
End If
IsFirstSeg = False
End If
If IsBorder = False Or i = tbRowN Then '不是框或到达表格最后则画线
If lineL > 0 Then
ptA(0) = 0
For j = 0 To iCol
ptA(0) = ptA(0) + tbColWs(j)
Next
ptA(0) = bsPt(0) + ptA(0)
ptB(0) = ptA(0)
ptA(1) = bsPt(1) - ptA(1)
ptB(1) = ptA(1) - lineL
Set aLine = wkSpace.AddLine(ptA, ptB)
End If
IsFirstSeg = True
lineL = 0
End If
Next
Next
'写文字
Dim mtStr As String
For iRow = 0 To tbRowN
For iCol = 0 To tbColN
ptA(0) = 0
ptA(1) = 0
ptB(0) = 0
ptB(1) = 0
lineL = 0
Set aRange = xlSh.cells(tbSRow + iRow, tbSCol + iCol)
If aRange.MergeCells = False Then
'行定位
For i = 0 To iCol
ptB(0) = ptB(0) + tbColWs(i)
Next
ptA(0) = ptB(0) - tbColWs(iCol)
'列定位
For i = 0 To iRow
ptA(1) = ptA(1) - tbRowHs(i)
Next
ptB(1) = ptA(1) + tbRowHs(iRow)
mtStr = xlSh.cells(tbSRow + iRow, tbSCol + iCol)
textH = xlSh.cells(tbSRow + iRow, tbSCol + iCol).Font.Size / 2.8346439
If mtStr <> "" Then
Call LnCAD_AddMText1(cadDrawing, wkSpace, bsPt(0) + ptA(0), bsPt(1) + ptA(1), bsPt(0) + ptB(0), bsPt(1) + ptB(1), textH, mtStr)
End If
Else
Set mrgRange = aRange.MergeArea
mrgRow = mrgRange.Row
mrgCol = mrgRange.Column
If iRow + tbSRow = mrgRow And iCol + tbSCol = mrgCol Then '合并单元格首格才写文字
mrgRowNp = mrgRange.Rows.Count
mrgColNp = mrgRange.Columns.Count
'表宽
For i = iCol To iCol + mrgColNp - 1
lineL = lineL + tbColWs(i)
Next
'行定位
For i = 0 To iCol + mrgColNp - 1
ptB(0) = ptB(0) + tbColWs(i)
Next
ptA(0) = ptB(0) - lineL
'表高
lineL = 0
For i = iRow To iRow + mrgRowNp - 1
lineL = lineL + tbRowHs(i)
Next
'列定位
For i = 0 To iRow + mrgRowNp - 1
ptA(1) = ptA(1) - tbRowHs(i)
Next
ptB(1) = ptA(1) + lineL
mtStr = xlSh.cells(tbSRow + iRow, tbSCol + iCol)
textH = xlSh.cells(tbSRow + iRow, tbSCol + iCol).Font.Size / 2.8346439
If mtStr <> "" Then
Call LnCAD_AddMText1(cadDrawing, wkSpace, bsPt(0) + ptA(0), bsPt(1) + ptA(1), bsPt(0) + ptB(0), bsPt(1) + ptB(1), textH, mtStr)
End If
End If
End If
Next
Next
'表格(Xl)结束
gvWb.Windows(1).Visible = True '窗口可见性
If lngR1 = 1 Then
gvWb.Close (False) '关闭(不保存)工作簿
End If
End Function
【函数】
'获得文件路径由对话框
'sys_Path:获得的路径
'sys_Dir:首选文件夹
'sys_Ext:文件后缀
Function Sys_GetPathByDlg(ByRef sys_Path As String, Optional sys_Dir As String = "d:\", Optional sys_Ext As String = "")
Dim i As Integer
Dim sys_DefaultExt As String
If sys_Ext = "" Then
sys_DefaultExt = "所有文件 (*.*)|*.*"
Else
sys_DefaultExt = "文件 (*." & sys_Ext & ")|*." & sys_Ext
End If
'<-获得主文件路径
Dim sys_Dlg As CmDlg64
Dim sys_Filse As Variant
Set sys_Dlg = New CmDlg64
With sys_Dlg
.DialogTitle = "打开文件"
.DefaultExt = "xls"
.Filter = sys_DefaultExt '可选文件类型
.flags = OFN_EXPLORER Or OFN_ALLOWMULTISELECT Or OFN_HIDEREADONLY
.InitDir = sys_Dir 'ThisDrawing.Path '"d:\" '默认打开的文件夹
If .ShowOpen Then
sys_Filse = .ParseFileNames
For i = 0 To UBound(sys_Filse)
Debug.Print sys_Filse(i)
Next
Else
Exit Function
End If
End With
sys_Path = sys_Dlg.fileName
End Function
'获取(Xl)Workbook对象
'Function : Xl_GetWorkbook
'Descrip :
'Call : IsFileOpen
'Input : aptPath:指定的绝对路径
'Output : xlWorkbook:获取的(Xl)Workbook对象
'Return : 0:获取失败,文件不存在 1:获取成功,初始未打开 2:获取成功,初始已打开
'History :2024-2-21 适用于ET表格
' 2024-4-17 改函数名
Public Function Xl_GetWorkbook(ByVal aptPath As String, ByRef xlWorkbook As Variant) As Long
'判断文件是否存在
If Dir(aptPath) = "" Then
Xl_GetWorkbook = 0
Exit Function
End If
'判断文件是否已打开
Dim IsOpen As Boolean
Dim xlApp As Object
Dim rCode As Long '返回代码
rCode = IsFileOpen(aptPath)
Dim aPath As String
If rCode = 0 Then
Set xlApp = CreateObject("ket.Application") '创建Xl对象
Set xlWorkbook = xlApp.Workbooks.Open(aptPath) '打开已经存在的Xl工件簿文件
Xl_GetWorkbook = 1
ElseIf rCode = 1 Then
Set xlApp = GetObject(, "ket.Application") '获得Xl对象
Set xlWorkbook = GetObject(aptPath) '获得Xl对象
Xl_GetWorkbook = 2
End If
End Function
'判断文件是否打开
'参数：argPath—绝对路径
'返回：0,未打开; 1,已打开
Public Function IsFileOpen(ByVal argPath As String) As Long
Dim oFile As Integer
oFile = FreeFile
On Error GoTo Err1
Open argPath For Binary Lock Read Write As oFile '以锁定读写方式打开，出错即被占用
Close oFile
IsFileOpen = 0
Exit Function
Err1:
IsFileOpen = 1
End Function
'获得工作空间
'gvLayoutName:布局名
Public Function LnCAD_GetWkSpace(gvDrawing As Object, ByRef wkSpace As Variant, Optional gvLayoutName As String = "")
If gvLayoutName <> "" Then
Dim iLayout As Integer
Dim existLayout As Boolean
existLayout = False
For iLayout = 0 To gvDrawing.Layouts.Count - 1
If LCase(gvDrawing.Layouts(iLayout).Name) = LCase(gvLayoutName) Then
existLayout = True
Exit For
End If
Next
If existLayout = True Then
gvDrawing.ActiveLayout = gvDrawing.Layouts(gvLayoutName)
End If
End If
If gvDrawing.ActiveSpace = 1 Then 'acModelSpace
Set wkSpace = gvDrawing.ModelSpace
Else
Set wkSpace = gvDrawing.PaperSpace
End If
End Function
'创建多行文字
'给定左下，右上角点，字高，内容
Public Function LnCAD_AddMText1(gvDrawing As Object, gvSpace As Variant, gvLBX As Double, gvLBY As Double, gvRTX As Double, gvRTY As Double, gvTextH As Double, gvStr As String)
gvDrawing.SetVariable "TextSize", gvTextH '字高
Dim mtWidth As Double '字宽
mtWidth = gvRTX - gvLBX
Dim mtHeight As Double '字高
mtHeight = gvRTY - gvLBY
Dim insPt(2) As Double'插入点
insPt(0) = (gvRTX + gvLBX - mtWidth) / 2
insPt(1) = (gvRTY + gvLBY + gvTextH) / 2
Dim aMText As Variant
Set aMText = gvSpace.AddMText(insPt, mtWidth, "0")
aMText.AttachmentPoint = acAttachmentPointMiddleCenter
aMText.LineSpacingDistance = gvTextH * 0.6 * 10 / 6 '行距比例
aMText.TextString = gvStr
'待改进：
'多行文字应先用单线字体生成，调整对齐后，再重新写入内容，truetype字体可能导致位置改变
End Function
【参数】
Option Explicit
'CommonDialogConst
' CommonDialog control flags
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_EXPLORER = &H80000
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Const OFN_SHOWHELP = &H10
' CommonDialog error flags
Private Const CDERR_DIALOGFAILURE = &HFFFF
Private Const CDERR_FINDRESFAILURE = &H6
Private Const CDERR_GENERALCODES = &H0
Private Const CDERR_INITIALIZATION = &H2
Private Const CDERR_LOADRESFAILURE = &H7
Private Const CDERR_LOADSTRFAILURE = &H5
Private Const CDERR_LOCKRESFAILURE = &H8
Private Const CDERR_MEMALLOCFAILURE = &H9
Private Const CDERR_MEMLOCKFAILURE = &HA
Private Const CDERR_NOHINSTANCE = &H4
Private Const CDERR_NOHOOK = &HB
Private Const CDERR_NOTEMPLATE = &H3
Private Const CDERR_REGISTERMSGFAIL = &HC
Private Const CDERR_STRUCTSIZE = &H1
【类】
'Class CmDlg64
'common dialog for x64
'history:
' 2024-3-1:support open , other not implemented
Option Explicit
'For X64
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAMEA) As Boolean
Private Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Type OPENFILENAMEA
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
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 LongPtr
lpTemplateName As String
End Type
Private Const ERROR_SUCCESS As Long = 0
Private Const MAX_PATH As Long = 260
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private mvarPath As String
Private mvarInitDir As String
Private mvarDialogTitle As String
Private mvarFilter As String
Private mvarUserFilter As String
Private mvarDefaultExt As String
Private mvarFileName As String
Private mvarFileTitle As String
Private mvarFilterIndex As Integer
Private mvarFlags As Long
Private mvarMaxFileSize As Integer
Private mvarErrorCode As Long
Private mvarErrorDescription As String
'Private accWnd As Long
Private Sub Class_Initialize()
mvarFlags = 0
mvarInitDir = ""
mvarFilter = "所有文件 (*.*)" & vbNullChar & "*.*"
mvarFilterIndex = 1
mvarDefaultExt = ""
mvarFileName = ""
mvarDialogTitle = ""
'mvarMaxFileSize = 256
'mvarFileName = String(mvarMaxFileSize, 0)
End Sub
Public Property Let InitDir(newVal As String)
mvarInitDir = newVal
End Property
Public Property Get InitDir() As String
InitDir = mvarInitDir
End Property
Public Property Let DialogTitle(ByVal newVal As String)
mvarDialogTitle = newVal
End Property
Public Property Get DialogTitle() As String
DialogTitle = mvarDialogTitle
End Property
Public Property Let Filter(ByVal newVal As String)
Dim TMP, i As Integer
TMP = Split(newVal, "|")
mvarFilter = ""
mvarUserFilter = newVal
For i = LBound(TMP) To UBound(TMP)
mvarFilter = mvarFilter & TMP(i) & Chr(0)
Next
mvarFilter = mvarFilter & Chr(0)
End Property
Public Property Get Filter() As String
Filter = mvarUserFilter
End Property
Public Property Get Path() As String
Path = mvarPath
End Property
Public Property Get DefaultExt() As String
DefaultExt = mvarDefaultExt
End Property
Public Property Let DefaultExt(ByVal newVal As String)
mvarDefaultExt = newVal
End Property
Public Property Let fileName(ByVal newVal As String)
mvarFileName = newVal
End Property
Public Property Get fileName() As String
fileName = mvarFileName
End Property
Public Property Get FileTitle() As String
FileTitle = mvarFileTitle
End Property
Public Property Let FilterIndex(ByVal newVal As Integer)
mvarFilterIndex = newVal
End Property
Public Property Get FilterIndex() As Integer
FilterIndex = mvarFilterIndex
End Property
Public Property Let flags(ByVal newVal As Long)
mvarFlags = newVal
End Property
Public Property Get flags() As Long
flags = mvarFlags
End Property
Public Property Let MaxFileSize(ByVal newVal As Integer)
mvarMaxFileSize = newVal
mvarFileName = String(newVal, 0)
End Property
Public Property Get MaxFileSize() As Integer
MaxFileSize = mvarMaxFileSize
End Property
Public Function ShowOpen() As Long
Dim RetVal As Boolean
Dim tsFN As OPENFILENAMEA
Dim strFileTitle As String
' Allocate string space for the returned strings.
mvarFileName = Left(mvarFileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With tsFN
.lStructSize = LenB(tsFN)
'.hwndOwner = Application.hWndAccessApp
.lpstrFilter = mvarFilter
.nFilterIndex = mvarFilterIndex
.lpstrFile = mvarFileName
.nMaxFile = Len(mvarFileName)
.lpstrFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.lpstrTitle = mvarDialogTitle
.flags = mvarFlags
.lpstrDefExt = mvarDefaultExt
.lpstrInitialDir = mvarInitDir
.hInstance = 0
.lpstrCustomFilter = String(255, 0)
.nMaxCustFilter = 255
.lpfnHook = 0
End With
RetVal = GetOpenFileName(tsFN)
If RetVal > 0 Then
mvarFileName = Left(tsFN.lpstrFile, InStr(tsFN.nFileOffset + 1, _
tsFN.lpstrFile, _
Chr(0) & Chr(0), _
vbBinaryCompare) _
)
mvarFileTitle = Trim(tsFN.lpstrFileTitle)
mvarPath = Left(mvarFileName, tsFN.nFileOffset)
Else
RetVal = -(CommDlgExtendedError)
End If
ShowOpen = RetVal
End Function
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
Dim i As Integer
i = InStr(strItem, vbNullChar)
If i > 0 Then
tsTrimNull = Left(strItem, i - 1)
Else
tsTrimNull = strItem
End If
tsTrimNull_End:
On Error GoTo 0
Exit Function
tsTrimNull_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFiles.tsTrimNull"
Resume tsTrimNull_End
End Function
Public Function ParseFileNames() As Variant
Dim TMP, RetVal(), i As Integer
Dim min As Integer, max As Integer
TMP = Split(mvarFileName, Chr(0))
min = LBound(TMP): max = UBound(TMP)
If min = max Then
ReDim RetVal(min To min)
RetVal(min) = mvarFileName
Else
ReDim RetVal(min To max - 1)
For i = min To max - 1
RetVal(i) = TMP(min) & "\" & TMP(i + 1)
Next
End If
ParseFileNames = RetVal
End Function
Private Function Split(ByVal str As String, ByVal Delim As String) As Variant
Dim tokens() As String, pos As Long, i As Integer
pos = InStr(1, str, Delim, vbTextCompare)
i = 0
Do While pos > 0
ReDim Preserve tokens(0 To i)
tokens(i) = Mid$(str, 1, pos - 1)
If tokens(i) = Delim Then tokens(i) = ""
str = Mid$(str, pos + Len(Delim))
i = i + 1
pos = InStr(1, str, Delim, vbTextCompare)
Loop
If Len(str) > 0 Then
ReDim Preserve tokens(0 To i)
tokens(i) = str
End If
Split = tokens
End Function
非常好 先收集 要是有文件的就好了 十五年前就有人写了类似功能，而且可以改线型颜色，我就是一直没搜到，记录网址如下：
http://bbs.mjtd.com/thread-82034-1-1.html
我这还重写了一个，不过也不算无用功，我这个程序生成的的线是连续的，不是每个单元格四条边线。也算是一个特点。 小白表示不知道如何在CAD中运用
页:
[1]