Attribute VB_Name = "模块1"
Public pic() As String
Public leftBottom(2) As Double
Public scaleFactor As Double
'*************系统类型与函数声明开始***************
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_NEWDIALOGSTYLE = &H40
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
'*************系统类型与函数声明结束***************
'此函数返回确保后面带反斜杠的文件路径
Public Function EnsurePath(ByVal sPath As String) As String
If Right(sPath, 1) <> "\" Then
EnsurePath = sPath & "\"
Else
EnsurePath = sPath
End If
End Function
Sub InsertRaster()
Dim a As AcadRasterImage
Dim picFolder, coordFolder, PicFileName As String
Dim ok As Boolean
Dim length As Integer
picFolder = GetFolder("请选择图片文件夹") '得到包含图片的文件夹
coordFolder = GetCoordfolder(picFolder) '得到包含坐标信息的文件夹
ListPics (picFolder) '找到所有图片的名字并存入到pic数组中
'MsgBox ArrayLength(pic)
length = ArrayLength(pic) '数组长度
scaleFactor = 10
'MsgBox coordFolder
'以下遍历两个文件夹找到照片以及对应的西南角坐标，并存入一个三维数组当中
Dim i As Integer
For i = 0 To length - 1
'MsgBox "正在处理" & pic(i)
ok = GetCoord(pic(i), coordFolder)
PicFileName = picFolder & "\" & pic(i)
Set a = ThisDrawing.Application.ActiveDocument.ModelSpace.AddRaster(PicFileName, leftBottom, scaleFactor, 0)
Next i
a.transparency = True
'a.Layer = "底图"
ThisDrawing.Application.ZoomExtents
MsgBox "成功导入: " & length & " 张图片!"
End Sub
Public Function ListPics(ByVal sPath As String)
Dim MyFile As String
'Dim s As String
Dim count As Integer
MyFile = Dir(sPath & "\" & "*.png")
count = count + 1
ReDim Preserve pic(count - 1)
pic(count - 1) = MyFile
's = s & count & "、" & MyFile
Do While MyFile <> ""
MyFile = Dir '第二次读入的时候不用写参数
If MyFile = "" Then
Exit Do '当MyFile为空的时候就说明已经遍历完了，这时退出Do，否则还要运行一遍
End If
count = count + 1
ReDim Preserve pic(count - 1)
pic(count - 1) = MyFile
Loop
End Function
Public Function GetCoord(ByVal picName As String, ByVal coordFolder As String) As Boolean
Dim coordFile As String
Dim count As Integer
coordFile = GetCoordFile(coordFolder)
Dim j As Integer
Dim mRegExp As Object '正则表达式对象
Dim mMatches As Object '匹配字符串集合对象
Dim mMatch As Object '匹配字符串
'MsgBox coordFile
Dim txt As String
Open coordFile For Input As #1 '
'对文件做任何 I/O 操作之前都必须先打开文件。Open 语句分配一个缓冲区供文件进行 I/O 之用，
'并决定缓冲区所使用的访问方式。
'打开文件作为数据输入用，文件号为#1
Do While Not EOF(1)
Line Input #1, txt '从已打开的顺序文件中读出一行并将它分配给 String 变量
If Right(txt, Len(picName)) = picName Then
'MsgBox picName
Line Input #1, txt '下一行就是西南角坐标
Set mRegExp = CreateObject("Vbscript.Regexp")
With mRegExp
.Global = True 'True表示匹配所有, False表示仅匹配第一个符合项
.IgnoreCase = True 'True表示不区分大小写, False表示区分大小写
.Pattern = "[\-|\+]?\d*[\.\d+]" '匹配字符模式
Set mMatches = .Execute(txt) '执行正则查找，返回所有匹配结果的集合，若未找到，则为空
For Each mMatch In mMatches
count = count + 1
leftBottom(count - 1) = CDbl(mMatch)
Next
End With
Set mRegExp = Nothing
Set mMatches = Nothing
count = 0
If ArrayLength(leftBottom) > 0 Then
'MsgBox leftBottom(0) & " " & leftBottom(1) & " " & leftBottom(2)
GetCoord = True
End If
End If
'MsgBox txt
Loop
Close #1
End Function
Public Function GetFolder(ByVal sTitle As String) As String
Dim bInf As BROWSEINFO
Dim retval As LongPtr
Dim PathID As LongPtr
Dim RetPath As String
Dim Offset As Integer
bInf.lpszTitle = sTitle
bInf.ulFlags = BIF_NEWDIALOGSTYLE
PathID = SHBrowseForFolder(bInf)
RetPath = Space$(512)
retval = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
If retval Then
Offset = InStr(RetPath, Chr$(0))
GetFolder = Left$(RetPath, Offset - 1)
End If
End Function
Public Function GetCoordfolder(ByVal picFolder As String) As String
GetCoordfolder = Replace(picFolder, "results", "info")
End Function
Public Function GetCoordFile(ByVal coordFolder As String) As String
Dim folder, MyFile As String
MyFile = Dir(coordFolder & "\" & "*.txt")
GetCoordFile = coordFolder & "\" & MyFile
End Function
Public Function ArrayLength(ByVal ary) As Integer
ArrayLength = UBound(ary) - LBound(ary) + 1
End Function
