Копирую сюда из другого топика.
Zalagaevда вот я недавно делал такую же задачу.
Сделал так. Беру лист xls. На нем jpg карта россии. На ней нарисованы города, объекты автоформ в виде кружочков и названия также. Потом к каждому нужному из возможных городов у меня нарисован callout — такая выноска с текстом.
Из базы аксовоской запускаю процедуру, она идет в xls.
1. перебирает ВСЕ автофигуры и выключает их фсе. скрывает.
2. из базы берем данные о городах и люлдях, что там работают,
включаем соотствующий callout — запихиваем туда данные. Показываем.
3. Так же показываем кружочки городов и красим их в зависимости от выбранного режима.
и так по циклу.
Проблема оказалась в Координатах. Ибо я не нашел способа четко указать координаты Выносок в X и Y — как то они указывается в каких-=то относительных координатах. Но мне все-равно, так как количество моих мест никогда не увеличится и не уменьшится. Просто включаю и выключаю то, что надо.
В Итоге получился такой код:
(минусов много.. но вдруг идея пригодится..)
Const dbname As String = "current2.mdb"
'Public curpath As String
Dim conntemp As New ADODB.Connection
' Check Distribute Method!
Public Sub aa()
For Each MyObject In ActiveSheet.Shapes ' Iterate through each element.
ActiveSheet.Shapes(MyObject.Name).Visible = True
Next
End Sub
Public Sub bb()
For Each MyObject In ActiveSheet.Shapes ' Iterate through each element.
ActiveSheet.Shapes(MyObject.Name).Visible = False
Next
ActiveSheet.Shapes("CommandButton7").Visible = True
End Sub
Public Sub callout_text()
Dim rsTemp As Recordset
Dim tmpSQL As String
Dim xlSheet As Worksheet
Dim iRow As Integer
Dim iCol As Integer
Dim today As Date
Dim key As Boolean ' distinguishes shapes in collection
Dim f, MyObject As Shape
Dim today2 As Date
'Starting column
iCol = 1
iRow = 0
Set xlSheet = ThisWorkbook.Sheets("1")
Set rsTemp = New ADODB.Recordset
tmpSQL = "SELECT employee_id, name FROM Employees;"
' today = CDate("27-10-06")
ThisWorkbook.Sheets(1).Cells(2, 16) = Date
today2 = ThisWorkbook.Sheets(1).Cells(2, 16)
tmpSQL2 = "SELECT Employees.Employee_ID, Employees.Name, Appointments.Date_Start, Appointments.Date_Finish, Staffing_List.fm_id, Projects.Project_title, FM.mapID " & _
"FROM Projects INNER JOIN (FM INNER JOIN (Staffing_List INNER JOIN " & _
"((Employees INNER JOIN Appointments ON Employees.Employee_ID = Appointments.EiaNio?oaieea) " & _
"INNER JOIN CurrentEmpl ON Appointments.AppointmentID = CurrentEmpl.AppointmentID) ON Staffing_List.staff_list_id = Appointments.StaffListID) " & _
"ON FM.FM_ID = Staffing_List.fm_id) ON Projects.Project_id = FM.Project_ID " & _
"WHERE (((Appointments.Date_Start)<= #" & Format(today2, "mm\/dd\/yyyy") & "#) AND ((Appointments.Date_Finish)>=" & Format(today2, "mm\/dd\/yyyy") & "));"
'Connect to the database
connectDB
Set rsTemp = conntemp.Execute(tmpSQL2)
' so by this I mean to say that firstly I want to
' go through every item in Shapes collection
'Get Data
ActiveSheet.Shapes("Group7").Visible = True
' Clear-up shapes texts beforehand
' Selection.Characters.Text = ""
For Each MyObject In ActiveSheet.Shapes ' Iterate through each element.
If MyObject.AutoShapeType = 110 Then
ActiveSheet.Shapes(MyObject.Name).Visible = True
ActiveSheet.Shapes(MyObject.Name).Select
' ActiveSheet.Shapes(MyObject.Name).Callout.AutoLength
' ActiveSheet.Shapes(MyObject.Name).TextFrame.AutoSize = True
Selection.Characters.Text = ""
ActiveSheet.Shapes(MyObject.Name).Visible = False
End If
Next
Do While Not rsTemp.EOF
iRow = iRow + 1
xlSheet.Cells(iRow + 1, iCol).Value = rsTemp("employee_id")
xlSheet.Cells(iRow + 1, iCol + 1).Value = rsTemp("name")
xlSheet.Cells(iRow + 1, iCol + 2).Value = CDate(rsTemp("Date_Start"))
xlSheet.Cells(iRow + 1, iCol + 3).Value = CDate(rsTemp("Date_Finish"))
xlSheet.Cells(iRow + 1, iCol + 4).Value = rsTemp("fm_id")
xlSheet.Cells(iRow + 1, iCol + 5).Value = rsTemp("Project_title")
xlSheet.Cells(iRow + 1, iCol + 6).Value = rsTemp("mapID")
key = False
For Each MyObject In ActiveSheet.Shapes ' Iterate through each element.
If MyObject.Name = "AutoShape " & rsTemp("mapID") Then
ActiveSheet.Shapes(MyObject.Name).Visible = True
ActiveSheet.Shapes(MyObject.Name).Select
Selection.Characters.Text = Selection.Characters.Text & rsTemp("name") & Chr(10)
key = True
' Selection.TextFrame.MarginBottom = 0
End If
If InStr(1, MyObject.Name, "CommandButton") > 0 Then
ActiveSheet.Shapes(MyObject.Name).Visible = True
'MsgBox ("Knopka")
key = True
End If
If MyObject.Name = "Group7" Then
ActiveSheet.Shapes(MyObject.Name).Visible = True
'MsgBox ("Risunok")
key = True
End If
If key = False Then
'MsgBox ("Iaoea")
ActiveSheet.Shapes(MyObject.Name).Visible = True
End If
Found = False ' Initialize variable.
Next
rsTemp.MoveNext
Loop
'Number of rows in this data set
xlSheet.Cells(1, iCol).Value = iRow
'Close the recordset and connection
rsTemp.Close
Set rsTemp = Nothing
disconnectDB
End Sub
' DB connection procedures
Public Function getConnectionVal()
'curpath = CurDir()
curpath = ThisWorkbook.Path & "\"
'curpath = "C:\Documents and Settings\DVZalagaev\Desktop\DB Development\"
If Dir(curpath & "\" & dbname) <> "" Then
Set xlSheet = ThisWorkbook.Sheets("1")
xlSheet.Cells(1, 1).Value = curpath
Dim dsntemp As String
dsntemp = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & curpath & dbname
getConnectionVal = dsntemp
xlSheet.Cells(2, 1).Value = dsntemp
Else
getConnectionVal = False
End If
End Function
Public Function connectDB()
On Error Resume Next
If Not isConnected Then
dsntemp = getConnectionVal
Set conntemp = New ADODB.Connection
conntemp.Open dsntemp
End If
End Function
Public Sub disconnectDB()
On Error Resume Next
conntemp.Close
Set conntemp = Nothing
End Sub
Public Function isConnected() As Boolean
On Error Resume Next
isConnected = False
If IsObject(conntemp) And Not conntemp Is Nothing Then
If conntemp.State = 1 Then isConnected = True
End If
End Function
данное сообщение получено с www.gotdotnet.ru
ссылка на оригинальное сообщение
