Excel批量按页自动打印南方CASS格式测量地形数据的VBA宏

测量数据(仅指测量坐标成果数据,一般为南方CASS格式,参见下表)从仪器下载下来后,都需要打印出来签字存档,如果手动排版将是一项繁琐的工作。可在Excel中添加一个宏,将数据读出按格式分页...

attachments-2020-07-Wl8yCauY5f183a057782e.png测量数据(仅指测量坐标成果数据,一般为南方CASS格式,参见下表)从仪器下载下来后,都需要打印出来签字存档,如果手动排版将是一项繁琐的工作。可在Excel中添加一个宏,将数据读出按格式分页排版,不管有多少数据,都可以快速搞定。对于有大量测量数据需要打印的工程项目,可显著提高工作效率。


;Pn,,E,N,H南方CASS格式

1,,268673.851,122259.312443,5104255.164807

2,,268674.254,122261.892475,5104252.195585

如下设计好模板: 


attachments-2020-07-1G0KBt9L5f1839b77ec60.png


点击表旁的“打开CASS文件”


attachments-2020-07-jISC7IeS5f1839d1dbe2d.png

选中一个数据文件,完成读入并分页: 

attachments-2020-07-QjQ1VcCY5f1839e86fb80.png


下图是在Excel中的打印效果,设计排版的表格模板在WPS里因兼容打印分页有点点问题,有兴趣的朋友可将表中行高稍作调整即可。




VBA宏代码如下: 


Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public CoSys_AX As Double

Public CoSys_AY As Double

Public CoSys_BX As Double

Public CoSys_BY As Double

Public CoSys_Az As Double

 

Public Ba_Min_x As Double

Public Ba_Min_y As Double

Public Ba_Min_H As Double

 

Public Ba_Max_x As Double

Public Ba_Max_y As Double

Public Ba_Max_H As Double

 

Const Start_Row = 6 '数据起始位置

Const Count_PerPage = 100 '每页数据个数,必须为偶数

 

Private Sub CommandButton1_Click()

    Dim Dia1 As Object, Strr As String, PPath As String

    Dim Datums As Variant

    Dim row As Long, RowIndex As Long, col As Long, DataCount As Long, PageIndex As Long

    Dim stageStr As String, stageStr_Min_X As String, stageStr_Min_Y As String, stageStr_Max_X As String, stageStr_Max_Y As String, stageStr_Min_H As String, stageStr_Max_H As String

'定义大坝坐标系

CoSys_AX = 3743173.79

CoSys_AY = 269083.559

CoSys_BX = 3743173.79

CoSys_BY = 268415.559

CoSys_Az = 270# * 3.14159265 / 180#

 

Ba_Min_x = -999999#

Ba_Min_y = -999999#

Ba_Min_H = -999999#

 

Ba_Max_x = -999999#

Ba_Max_y = -999999#

Ba_Max_H = -999999#

    

    row = 0

    DataCount = 1

    Set Dia1 = Application.FileDialog(msoFileDialogFilePicker)

    Dia1.Title = "(C) QinDong QQ:61902475 Email:qd@cehuis.com V20160225"

    With Dia1

        .AllowMultiSelect = False '限制只能同时选择一个文件

        .Filters.Clear

        .Filters.Add "南方CASS格式", "*.dat", 1 '限制显示的文件类型

        .Show

        For Each vrtSelectedItem In .SelectedItems

            PPath = vrtSelectedItem

        Next

    End With

    If Trim(PPath) <> "" Then

        Open PPath For Input As #1

            Do While Not EOF(1)

                Line Input #1, Strr

                If Trim(Strr) <> "" Then

                Datums = Split(Strr, ",")

                If UBound(Datums) = 4 Then

                CalStage Val(Datums(3)), Val(Datums(2)), Val(Datums(4)) '计算大坝坐标桩号

                PageIndex = Int((DataCount - 1) / Count_PerPage)

                RowIndex = Int((DataCount - 1 - PageIndex * Count_PerPage) / (Count_PerPage / 2))

                If RowIndex = 0 Then

                 col = 2

                Else

                 col = Start_Row '6

                End If

                        '增加一页

                        If DataCount = PageIndex * Count_PerPage + 1 Then

                            Range("A" & Start_Row & ":H" & ((Count_PerPage / 2) + Start_Row - 1)).Select

                            Application.CutCopyMode = False

                            Selection.Copy

                            Range("A" & (PageIndex * (Count_PerPage / 2) + Start_Row)).Select

                            ActiveSheet.Paste

                            Range("A" & (PageIndex * (Count_PerPage / 2) + Start_Row) & ":" & "H" & ((PageIndex + 1) * (Count_PerPage / 2) + Start_Row - 1)).Select

                            Selection.RowHeight = 13

                            Selection.ClearContents

                        End If

                If (DataCount - 1) Mod (Count_PerPage / 2) = 0 Then row = 0

                    Sheet1.Cells(PageIndex * (Count_PerPage / 2) + Start_Row + row, col - 1) = DataCount

                    Sheet1.Cells(PageIndex * (Count_PerPage / 2) + Start_Row + row, col) = Datums(3)

                    Sheet1.Cells(PageIndex * (Count_PerPage / 2) + Start_Row + row, col + 1) = Datums(2)

                    Sheet1.Cells(PageIndex * (Count_PerPage / 2) + Start_Row + row, col + 2) = Datums(4)

                row = row + 1

                DataCount = DataCount + 1

                End If

                End If

            Loop

        Close #1

        '设置打印区域

        ActiveSheet.PageSetup.PrintArea = "$A$" & (Start_Row - 1) & ":$H$" & ((PageIndex + 1) * (Count_PerPage / 2) + Start_Row - 1)

    

    '探测桩号范围

    stageStr_Min_X = "纵0+" & Format(Round(Ba_Min_x, 2), "0.00")

    stageStr_Max_X = "纵0+" & Format(Round(Ba_Max_x, 2), "0.00")

    

    '适用于两河口,偏距要反号

    If Ba_Min_y > 0 Then

    stageStr_Min_Y = "坝0" & Format(-Round(Ba_Min_y, 2), "0.00")

    Else

    stageStr_Min_Y = "坝0+" & Format(-Round(Ba_Min_y, 2), "0.00")

    End If

    

    If Ba_Max_y > 0 Then

    stageStr_Max_Y = "坝0" & Format(-Round(Ba_Max_y, 2), "0.00")

    Else

    stageStr_Max_Y = "坝0+" & Format(-Round(Ba_Max_y, 2), "0.00")

    End If

    

    stageStr_Min_H = "EL." & Format(Round(Ba_Min_H, 2), "0.00")

    stageStr_Max_H = "EL." & Format(Round(Ba_Max_H, 2), "0.00")

    

    If Ba_Min_y > 0 Then

    stageStr = "(" & stageStr_Min_X & "~" & stageStr_Max_X & ";" & stageStr_Min_Y & "~" & stageStr_Max_Y & ";" & stageStr_Min_H & "~" & stageStr_Max_H & ")"

    ElseIf Ba_Min_y < 0 And Ba_Max_y > 0 Then

    stageStr = "(" & stageStr_Min_X & "~" & stageStr_Max_X & ";" & stageStr_Max_Y & "~" & stageStr_Min_Y & ";" & stageStr_Min_H & "~" & stageStr_Max_H & ")"

    ElseIf Ba_Max_y < 0 Then

    stageStr = "(" & stageStr_Min_X & "~" & stageStr_Max_X & ";" & stageStr_Max_Y & "~" & stageStr_Min_Y & ";" & stageStr_Min_H & "~" & stageStr_Max_H & ")"

    Else

    stageStr = "(" & stageStr_Min_X & "~" & stageStr_Max_X & ";" & stageStr_Min_Y & "~" & stageStr_Max_Y & ";" & stageStr_Min_H & "~" & stageStr_Max_H & ")"

    End If

    

    Range("A3:H3").Select

    Selection.Font.Bold = False

    Range("A3:H3").Select

    ActiveCell.FormulaR1C1 = "工程部位:" & stageStr

    With ActiveCell.Characters(Start:=1, Length:=5).Font

        .Name = "黑体"

        .FontStyle = "加粗"

        .Size = 10

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ColorIndex = xlAutomatic

    End With

   

    End If

End Sub

 

 

'计算桩号范围

Public Sub CalStage(pn As Double, pe As Double, ph As Double)

Dim px_tmp As Double, py_tmp As Double

px_tmp = Round((pn - CoSys_AX) * Cos(CoSys_Az) + (pe - CoSys_AY) * Sin(CoSys_Az), 3)

py_tmp = Round(-(pn - CoSys_AX) * Sin(CoSys_Az) + (pe - CoSys_AY) * Cos(CoSys_Az), 3)

 

If Ba_Min_x = -999999# Or px_tmp < Ba_Min_x Then Ba_Min_x = px_tmp

If Ba_Min_y = -999999# Or py_tmp < Ba_Min_y Then Ba_Min_y = py_tmp

If Ba_Min_H = -999999# Or ph < Ba_Min_H Then Ba_Min_H = ph

 

If Ba_Max_x = -999999# Or px_tmp > Ba_Max_x Then Ba_Max_x = px_tmp

If Ba_Max_y = -999999# Or py_tmp > Ba_Max_y Then Ba_Max_y = py_tmp

If Ba_Max_H = -999999# Or ph > Ba_Max_H Then Ba_Max_H = ph


————————————————

版权声明:本文为CSDN博主「Qin Dong」的原创文章,遵循CC 4.0 BY-SA版权协议,转载请附上原文出处链接及本声明。

原文链接:https://blog.csdn.net/hjpqindong/article/details/91310006

  • 发表于 2020-07-22 21:08
  • 阅读 ( 1424 )
  • 分类:软件教程

你可能感兴趣的文章

相关问题

0 条评论

请先 登录 后评论
admin
admin

213 篇文章

作家榜 »

  1. admin 213 文章
  2. 在那夜黑风高的夜晚 53 文章
  3. 老K 20 文章
  4. 朱晨曦 17 文章
  5. 胡亮 10 文章
  6. 张工 8 文章
  7. 肖肖 6 文章
  8. 通测工作室 5 文章