-
Notifications
You must be signed in to change notification settings - Fork 2
/
calcimage7.bas
239 lines (183 loc) · 7.72 KB
/
calcimage7.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
Attribute VB_Name = "CodeCalcImage7"
' (c) Copyright 1995-2024 by John J. Donovan
Option Explicit
' Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
' in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
' copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
' FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
' IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
' Output data for GRD files
Dim PrbImgData(1 To 1) As TypeImageData
Sub CalcImageCreateGRDFromArray(tfilename As String, ix As Integer, iy As Integer, sarray() As Single, xmin As Double, xmax As Double, ymin As Double, ymax As Double, zmin As Double, zmax As Double)
' Create and save a GRD file from the passed array to the passed filename
ierror = False
On Error GoTo CalcImageCreateGRDFromArrayError
Dim ii As Long, jj As Long
' Check for no x or y extents
If xmax# = xmin# Or ymax# = ymin# Then GoTo CalcImageCreateGRDFromArrayBadExtents
PrbImgData(1).id$ = "DSBB"
PrbImgData(1).ix% = ix%
PrbImgData(1).iy% = iy%
' Load stage extents (note min and max are swapped for JEOL)
PrbImgData(1).xmin# = xmin#
PrbImgData(1).xmax# = xmax#
PrbImgData(1).ymin# = ymin#
PrbImgData(1).ymax# = ymax#
PrbImgData(1).zmin# = zmin#
PrbImgData(1).zmax# = zmax#
' Dimension array
ReDim PrbImgData(1).gData(1 To ix%, 1 To iy%) As Single
Screen.MousePointer = vbHourglass
' Load data image data
For jj& = 1 To iy%
For ii& = 1 To ix%
PrbImgData(1).gData!(ii&, jj&) = sarray!(ii&, jj&)
Next ii&
Next jj&
' Load the file based on actual file version number
If SurferOutputVersionNumber% = 6 Then
Call GridFileReadWrite(Int(2), Int(1), PrbImgData(), tfilename$)
If ierror Then
Screen.MousePointer = vbDefault
Exit Sub
End If
Else
Call GridFileReadWrite2(Int(2), Int(1), PrbImgData(), tfilename$)
If ierror Then
Screen.MousePointer = vbDefault
Exit Sub
End If
End If
Exit Sub
' Errors
CalcImageCreateGRDFromArrayError:
Screen.MousePointer = vbDefault
MsgBox Error$, vbOKOnly + vbCritical, "CalcImageCreateGRDFromArray"
ierror = True
Exit Sub
CalcImageCreateGRDFromArrayBadExtents:
Screen.MousePointer = vbDefault
msg$ = "File " & tfilename$ & " has equal x and/or y extents and is therefore not a valid GRD file (xmin= " & Format$(xmin#) & ", xmax= " & Format$(xmax#) & ", ymin= " & Format$(ymin#) & ", ymax= " & Format$(ymax#) & ") . Please try again."
MsgBox msg$, vbOKOnly + vbExclamation, "CalcImageCreateGRDFromArray"
ierror = True
Exit Sub
End Sub
Sub CalcImageCreateGRDFromArrayD(tfilename As String, ix As Long, iy As Long, sarray() As Double, xmin As Double, xmax As Double, ymin As Double, ymax As Double, zmin As Double, zmax As Double)
' Create and save a GRD file from the passed double precision array to the passed filename
ierror = False
On Error GoTo CalcImageCreateGRDFromArrayDError
Dim i As Long, j As Long
' Check for no x or y extents
If xmax# = xmin# Or ymax# = ymin# Then GoTo CalcImageCreateGRDFromArrayDBadExtents
PrbImgData(1).id$ = "DSBB"
PrbImgData(1).ix% = ix&
PrbImgData(1).iy% = iy&
' Load stage extents (note min and max are swapped for JEOL)
PrbImgData(1).xmin# = xmin#
PrbImgData(1).xmax# = xmax#
PrbImgData(1).ymin# = ymin#
PrbImgData(1).ymax# = ymax#
PrbImgData(1).zmin# = zmin#
PrbImgData(1).zmax# = zmax#
' Dimension array
ReDim PrbImgData(1).gData(1 To ix&, 1 To iy&) As Single
Screen.MousePointer = vbHourglass
' Load data image data
For j& = 1 To iy&
For i& = 1 To ix&
PrbImgData(1).gData!(i&, j&) = sarray#(i&, j&)
Next i&
Next j&
' Load the file based on actual file version number
If SurferOutputVersionNumber% = 6 Then
Call GridFileReadWrite(Int(2), Int(1), PrbImgData(), tfilename$)
If ierror Then
Screen.MousePointer = vbDefault
Exit Sub
End If
Else
Call GridFileReadWrite2(Int(2), Int(1), PrbImgData(), tfilename$)
If ierror Then
Screen.MousePointer = vbDefault
Exit Sub
End If
End If
Exit Sub
' Errors
CalcImageCreateGRDFromArrayDError:
Screen.MousePointer = vbDefault
MsgBox Error$, vbOKOnly + vbCritical, "CalcImageCreateGRDFromArrayD"
ierror = True
Exit Sub
CalcImageCreateGRDFromArrayDBadExtents:
Screen.MousePointer = vbDefault
msg$ = "File " & tfilename$ & " has equal x and/or y extents and is therefore not a valid GRD file (xmin= " & Format$(xmin#) & ", xmax= " & Format$(xmax#) & ", ymin= " & Format$(ymin#) & ", ymax= " & Format$(ymax#) & ") . Please try again."
MsgBox msg$, vbOKOnly + vbExclamation, "CalcImageCreateGRDFromArrayD"
ierror = True
Exit Sub
End Sub
Sub CalcImageCreateGRDFromArray2(tfilename As String, ix As Integer, iy As Integer, n As Integer, sarray() As Single, xmin As Double, xmax As Double, ymin As Double, ymax As Double, zmin As Double, zmax As Double)
' Create and save a GRD file from the passed array to the passed filename (3 dimensional sarray)
ierror = False
On Error GoTo CalcImageCreateGRDFromArray2Error
Dim i As Integer, j As Integer
' Check for no x or y extents
If xmax# = xmin# Or ymax# = ymin# Then GoTo CalcImageCreateGRDFromArray2BadExtents
' Check image size
If ix% = 0 Or iy% = 0 Then GoTo CalcImageCreateGRDFromArray2BadSize
PrbImgData(1).id$ = "DSBB"
PrbImgData(1).ix% = ix%
PrbImgData(1).iy% = iy%
' Load stage extents (note min and max are swapped for JEOL)
PrbImgData(1).xmin# = xmin#
PrbImgData(1).xmax# = xmax#
PrbImgData(1).ymin# = ymin#
PrbImgData(1).ymax# = ymax#
PrbImgData(1).zmin# = zmin#
PrbImgData(1).zmax# = zmax#
' Dimension array
ReDim PrbImgData(1).gData(1 To ix%, 1 To iy%) As Single
Screen.MousePointer = vbHourglass
' Load data image data
For j% = 1 To iy%
For i% = 1 To ix%
PrbImgData(1).gData!(i%, j%) = sarray!(i%, j%, n%)
Next i%
Next j%
' Load the file based on actual file version number
If SurferOutputVersionNumber% = 6 Then
Call GridFileReadWrite(Int(2), Int(1), PrbImgData(), tfilename$)
If ierror Then
Screen.MousePointer = vbDefault
Exit Sub
End If
Else
Call GridFileReadWrite2(Int(2), Int(1), PrbImgData(), tfilename$)
If ierror Then
Screen.MousePointer = vbDefault
Exit Sub
End If
End If
Exit Sub
' Errors
CalcImageCreateGRDFromArray2Error:
Screen.MousePointer = vbDefault
MsgBox Error$ & ", processing grid file " & tfilename$, vbOKOnly + vbCritical, "CalcImageCreateGRDFromArray2"
ierror = True
Exit Sub
CalcImageCreateGRDFromArray2BadExtents:
Screen.MousePointer = vbDefault
msg$ = "File " & tfilename$ & " has equal x and/or y extents and is therefore not a valid GRD file (xmin= " & Format$(xmin#) & ", xmax= " & Format$(xmax#) & ", ymin= " & Format$(ymin#) & ", ymax= " & Format$(ymax#) & ") . Please try again."
MsgBox msg$, vbOKOnly + vbExclamation, "CalcImageCreateGRDFromArray2"
ierror = True
Exit Sub
CalcImageCreateGRDFromArray2BadSize:
Screen.MousePointer = vbDefault
msg$ = "File " & tfilename$ & " has zero x and/or y dimensions and is therefore not a valid GRD file (ix= " & Format$(ix%) & ", iy= " & Format$(iy%) & "). Please try again."
MsgBox msg$, vbOKOnly + vbExclamation, "CalcImageCreateGRDFromArray2"
ierror = True
Exit Sub
End Sub