Imports System.IO Imports System.Threading Imports System.Threading.Channels Imports System.Windows.Forms.VisualStyles.VisualStyleElement Imports CorelDRAW Imports CorelDRAW.RuningLog Imports Newtonsoft.Json Imports StackExchange.Redis Imports VGCore Public Class CorelDRAW Public M_Redisip As String = "127.0.0.1" Public M_Redisport As Integer = 10079 ' 6379 ' 10079 ' 10079 '10079 ' 10079 Public M_Redispassword As String = "blw@redis-ser@123" ' "" ' "blw@redis-ser@123" '"blw@redis-ser@123" ' "blw@redis-ser@123" ' "" ' 'redis消息队列 Public M_RedisQueue As Queue '事件处理线程 Public M_EventThread As Thread '服务器文件路径 Private M_ServerPath As String = "R:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' "D:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' "R:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' "R:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" '"D:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' "R:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' '素材库路径 Private M_MaterialPath As String = "R:\Canvas\material\" '"D:\Canvas\material\" ' "R:\Canvas\material\" ' "R:\Canvas\material\" ' "R:\Canvas\material\" ' '成平文件路径 Private M_TplPath As String = "D:\CorelDRAW\" Public G_RedisSub, G_Redislish As RedisSubscriber '发布字段 Public G_Publish As String = "" Public G_Subscribe As String = "" Public G_OldSubscribe As String = "" '日志对象 Public G_Log As RuningLog Public APP As Object Public G_LibDoc As Document '数据库连接字符串 Public LocalConnString As String = "server=10.8.8.208;database=cdr_library;charset=utf8;uid=BLWlog;pwd=Blw@1234;port=16036" Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load '定义一个画布 Text = "CorelDRAW" & "_" & System.Windows.Forms.Application.ProductVersion M_RedisQueue = New Queue() '启动事件处理线程 M_EventThread = New Thread(AddressOf EventThread) M_EventThread.Start() 'Dim t As Type = Type.GetTypeFromProgID("CorelDRAW.Application.22") 'If t IsNot Nothing Then ' Console.WriteLine("COM 已注册，可以连接！") 'Else ' Console.WriteLine("COM 未注册！") 'End If APP = New Application() Thread.Sleep(300) APP.Visible = False ' Dim MaterialPath As String = M_MaterialPath & "素材模板.cdr" 'G_LibDoc = APP.OpenDocument(MaterialPath, False) G_Log = New RuningLog(RichTextBox1, System.Windows.Forms.Application.StartupPath & "\log") GetSeting() initRedisSubscriber(G_Subscribe, G_OldSubscribe) initRedisPublisher() End Sub Private Sub EventThread() Dim item As RedisMsgNode While True If M_RedisQueue.Count > 0 Then item = M_RedisQueue.Dequeue() If item Is Nothing Then Continue While Select Case item.MsgType Case 1 Dim MsgNode = JsonConvert.DeserializeObject(Of RedisInfoNode)(item.MsgNode.ToString) DisposeRedisMsgNode1(MsgNode) Case 2 Dim MsgNode = JsonConvert.DeserializeObject(Of PreviewRoomTypePanel)(item.MsgNode.ToString) DisposeOverviewRedisMsgNode(MsgNode) 'DisposeRedisMsgNode2(MsgNode) End Select End If System.Threading.Thread.Sleep(10) End While End Sub Sub DisposeRedisMsgNode1(item As RedisInfoNode) Dim gLogNode As LogNode Try gLogNode = New LogNode($"开始进行用户【{item.User}】_[{item.ProjectName}]项目[{item.TemplateName.Replace("Mode_", "") }]图像生成！", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) 'gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) If HandleNodeInformation3(item) Then gLogNode = New LogNode($"开始进行用户【{item.User}】_[{item.ProjectName}]项目[{item.TemplateName.Replace("Mode_", "") }]图像生成成功！", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) 'gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Else gLogNode = New LogNode($"开始进行用户【{item.User}】_[{item.ProjectName}]项目[{item.TemplateName.Replace("Mode_", "") }]图像生成失败！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) End If Catch ex As Exception Dim RsNode As New RedisSendNode RsNode.User = item.User RsNode.ProjectName = item.ProjectName RsNode.ProjectId = item.ProjectId RsNode.PictureNum = item.PictureNum RsNode.Status = RedisSendNode.StatusType.SerializeFail RsNode.Process = item.Process RsNode.Msg = "序列化数据错误!" Dim RMNode As New RedisMsgNode RMNode.MsgType = 1 RMNode.MsgNode = RsNode RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"序列化数据错误！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) APP = New Application() Thread.Sleep(500) End Try End Sub Sub DisposeRedisMsgNode2(node As PreviewRoomTypePanel) Dim gLogNode As LogNode Dim filedir As String = M_ServerPath ' "D:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic" Dim RsNode As New RedisSendNode RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.PictureNum = node.picNum Dim RMNode As New RedisMsgNode RMNode.MsgType = 2 RMNode.MsgNode = RsNode Try InpotMessage1("1、文档初始化") gLogNode = New LogNode($"生成酒店房间面板预览文档！", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) Dim doc As Document Try doc = APP.CreateDocument() doc.Unit = cdrUnit.cdrMillimeter ' 设置单位为毫米 Catch ex As Exception APP = New Application() Thread.Sleep(1000) APP.Visible = False doc = APP.CreateDocument() doc.Unit = cdrUnit.cdrMillimeter ' 设置单位为毫米 End Try InpotMessage1("3、打开模板库并创建新文件等待构建图像") InpotMessage1("2、酒店标题生成") Dim hotelName As String = "" If node.project IsNot Nothing AndAlso node.project.Count > 0 Then hotelName = node.project(0).hotel_name RsNode.Guid = node.project(0).guid End If InpotMessage1("创建酒店标题文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = "创建酒店标题失败!!" 'Dim hotelText As Shape = doc.ActiveLayer.CreateArtisticText(0, 0, hotelName) Dim remark As String() = {"思源黑体", "48"} Dim hotelText As Shape = CreateTextImage2(doc.ActiveLayer, hotelName, remark) hotelText.CenterY = 0 hotelText.LeftX = 0 'With hotelText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 48 'End With ' 计算当前文档高度 Dim currentY As Double = hotelText.CenterY - 20 ' 标题底部向下50mm InpotMessage1("3、数据分组处理") Dim roomGroups As Dictionary(Of String, List(Of Panel)) = New Dictionary(Of String, List(Of Panel))() For Each panel As Panel In node.panels If Not roomGroups.ContainsKey(panel.room_name) Then roomGroups.Add(panel.room_name, New List(Of Panel)()) End If roomGroups(panel.room_name).Add(panel) Next InpotMessage1("4、房型分类处理") For Each roomName As String In roomGroups.Keys InpotMessage1("创建房型标题文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = "创建酒店房型标题失败!!" remark = {"思源黑体", "28"} Dim roomText As Shape = CreateTextImage2(doc.ActiveLayer, roomName, remark) roomText.CenterY = currentY roomText.LeftX = 0 'Dim roomText As Shape = doc.ActiveLayer.CreateArtisticText(0, currentY, roomName) 'With roomText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 28 'End With currentY = roomText.CenterY - (roomText.OriginalHeight / 2) - 10 ' 房型标题底部向下30mm Dim currentX As Double = 0 ' 当前行的X坐标 Dim maxHeight As Double = 0 ' 当前行最高图像的高度 InpotMessage1("遍历该房型对应的所有panel") For Each panel As Panel In roomGroups(roomName) Dim cdr_filename As String = $"{filedir}\{panel.cdr_filename}".Replace("\\", "\") InpotMessage1("5、CDR文件图像处理") If File.Exists(cdr_filename) Then InpotMessage1("打开CDR文件") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"拷贝文件{vbCrLf}{cdr_filename}{vbCrLf}中的面板图像失败!!" Dim cdrDoc As Document = APP.OpenDocument(cdr_filename, False) If cdrDoc.Pages.Count > 0 AndAlso cdrDoc.Pages(1).ActiveLayer.Shapes.Count > 0 Then InpotMessage1("复制第一个图像") Dim cdrShape As Shape = cdrDoc.Pages(1).ActiveLayer.Shapes(1) 'cdrShape.Copy() shapeCopy(cdrShape) InpotMessage1("粘贴到当前文档") Dim pastedShape As Shape = doc.ActiveLayer.Paste() 'doc.ActiveLayer.Shapes(doc.ActiveLayer.Shapes.Count) InpotMessage1("设置图像位置") pastedShape.LeftX = currentX pastedShape.CenterY = currentY - (pastedShape.OriginalHeight / 2) InpotMessage1("6、属性文本生成") InpotMessage1("生成panel_list_name文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"生成名称文本图像失败：{panel.panel_list_name} !!" remark = {"思源黑体", "24"} Dim listNameText As Shape = CreateTextImage2(doc.ActiveLayer, "名称：" & panel.panel_list_name, remark) Dim textY As Double = pastedShape.CenterY - (pastedShape.OriginalHeight / 2) - 10 listNameText.CenterY = textY listNameText.LeftX = currentX 'Dim listNameText As Shape = doc.ActiveLayer.CreateArtisticText(currentX, textY, "名称：" & panel.panel_list_name) 'With listNameText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 12 'End With InpotMessage1("生成position文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"生成位置文本图像失败：{panel.position} !!" Dim positionText As Shape = CreateTextImage2(doc.ActiveLayer, "位置：" & panel.position, remark) textY = listNameText.CenterY - (listNameText.OriginalHeight / 2) - 10 positionText.CenterY = textY positionText.LeftX = currentX 'Dim positionText As Shape = doc.ActiveLayer.CreateArtisticText(currentX, textY + 10, "位置：" & panel.position) 'With positionText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 12 'End With InpotMessage1("生成carving_quantity文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"生成数量文本图像失败：{panel.carving_quantity} !!" Dim quantityText As Shape = CreateTextImage2(doc.ActiveLayer, "数量：" & panel.carving_quantity, remark) textY = positionText.CenterY - (positionText.OriginalHeight / 2) - 10 quantityText.CenterY = textY quantityText.LeftX = currentX 'Dim quantityText As Shape = doc.ActiveLayer.CreateArtisticText(currentX, textY + 20, "数量：" & panel.carving_quantity) 'With quantityText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 12 'End With InpotMessage1("7、图文组合") pastedShape.Selected = True listNameText.Selected = True positionText.Selected = True quantityText.Selected = True Dim group As Shape = doc.SelectionRange.Group() group.Name = pastedShape.Name 'Path.GetFileNameWithoutExtension(panel.cdr_filename) group.Selected = False pastedShape.Selected = False listNameText.Selected = False positionText.Selected = False quantityText.Selected = False InpotMessage1("更新X坐标，为下一个图像留出50mm间距") InpotMessage1("计算当前行的最大高度") If group.OriginalHeight > maxHeight Then maxHeight = group.OriginalHeight End If currentX += pastedShape.SizeWidth + 50 Else RsNode.Status = RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = $"未找到文件{vbCrLf}{cdr_filename}{vbCrLf}中的图像!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ RsNode.Msg}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If InpotMessage1("关闭CDR文件") cdrDoc.Close() Else RsNode.Status = RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = $"文件{vbCrLf}{cdr_filename}{vbCrLf}不存在!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ RsNode.Msg}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If Next ' 更新Y坐标，为下一个房型留出50mm间距 currentY = currentY - maxHeight - 20 Next InpotMessage1("8、文档保存") RsNode.Status = RedisSendNode.StatusType.SaveFileFail RsNode.Msg = $"生成文件失败 !!" Dim savePath As String = $"{filedir}\{hotelName}\{Now:yyyyMMdd}" If Not Directory.Exists(savePath) Then Directory.CreateDirectory(savePath) End If Dim cdrFileName As String = $"{node.picNum}.cdr" Dim cdrFilePath As String = Path.Combine(savePath, cdrFileName) Dim ssao As New StructSaveAsOptions ssao.Filter = VGCore.cdrFilter.cdrCDR ssao.Range = VGCore.cdrExportRange.cdrAllPages ssao.Version = VGCore.cdrFileVersion.cdrVersion19 doc.SaveAs(cdrFilePath, ssao) 'InpotMessage1("9、文档导出") 'Dim pltFileName As String = $"PreviewRoomTypePanel{node.picNum}.plt" 'Dim pltFilePath As String = Path.Combine(savePath, pltFileName) 'doc.Export(pltFilePath, cdrExportFileFormat.cdrPLT) InpotMessage1("关闭文档") doc.Close() RsNode.Status = RedisSendNode.StatusType.Success RsNode.Msg = "Ok" RsNode.CdrPath = cdrFilePath.Replace(filedir & "\", "") RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) InpotMessage1($"18、向Redis写入生成成功信息") gLogNode = New LogNode($"成功生成酒店房间面板预览文档：{cdrFilePath}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) Return Catch ex As Exception RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) End Try End Sub Sub DisposeOverviewRedisMsgNode(node As PreviewRoomTypePanel) Dim gLogNode As LogNode Dim filedir As String = M_ServerPath ' "D:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic" Dim RsNode As New RedisSendNode RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.PictureNum = node.picNum Dim RMNode As New RedisMsgNode RMNode.MsgType = 2 RMNode.MsgNode = RsNode Dim hotelText, hotelnodeText, kuang_lin As Shape Dim nodeText As String Dim bProject As Project = Nothing Dim remark As String() = {"思源黑体", "36"} Try InpotMessage1("1、文档初始化") gLogNode = New LogNode($"生成酒店房间面板预览文档！", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) Dim doc As Document Try doc = APP.CreateDocument() doc.Unit = cdrUnit.cdrMillimeter ' 设置单位为毫米 Catch ex As Exception APP = New Application() Thread.Sleep(1000) APP.Visible = False doc = APP.CreateDocument() doc.Unit = cdrUnit.cdrMillimeter ' 设置单位为毫米 End Try InpotMessage1("2、打开总览框 模板 拷贝模版") Dim overviewFilePath As String = Path.Combine(M_MaterialPath, "BLV_总览框.cdr") Dim overviewDoc As Document = Nothing Dim previewBox As Shape = Nothing Dim currentY As Double Dim hotelName As String = "" Dim projectTitleShape As Shape = Nothing If Not File.Exists(overviewFilePath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = $"未找到文件{vbCrLf}BLV_总览框.cdr!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"BLV_总览框.cdr文件不存在:：{ overviewFilePath}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) doc.Close() Return Else InpotMessage1("3、处理标题信息") If node.project IsNot Nothing AndAlso node.project.Count > 0 Then hotelName = node.project(0).hotel_name bProject = node.project(0) Else RsNode.Status = RedisSendNode.StatusType.SerializeFail RsNode.Msg = $"未找到标题信息!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ RsNode.Msg}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) doc.Close() Return End If Dim chpcolor As Color = New Color chpcolor.RGBAssign(0, 140, 140) Dim ZcdrDoc As Document = APP.OpenDocument(overviewFilePath, False) If ZcdrDoc.Pages.Count > 0 AndAlso ZcdrDoc.Pages(1).ActiveLayer.Shapes.Count > 0 Then hotelText = ZcdrDoc.Pages(1).ActiveLayer.Shapes(1) '将hotelText 拷贝到doc InpotMessage1("将总览框拷贝文件中") shapeCopy(hotelText) hotelText = doc.ActiveLayer.Paste() '设置总览框图形中心点与文档中心点一致 hotelText.CenterX = doc.ActivePage.CenterX hotelText.CenterY = doc.ActivePage.CenterY hotelText.TopY = doc.ActivePage.TopY '设置总览框图形原点 为垂直居上水平居中 ZcdrDoc.Close() '查找hotelText中名称为 Project_Title 的形状 hotelText.Ungroup() For Each shape As Shape In doc.Pages(1).ActiveLayer.Shapes If shape.Name.ToLower.Equals("Project_Title".ToLower) Then projectTitleShape = shape '遍历其子形状，查找名称为 PreviewBox 的形状 End If 'kuang_lin If shape.Name.ToLower.Equals("kuang_lin".ToLower) Then kuang_lin = shape End If Next For Each childShape As Shape In projectTitleShape.Shapes nodeText = "" '当名称分别为Txt_EnglishFont、Txt_SocketSeries、Txt_ChineseFont、Txt_SwitchSeries、Txt_Data、Txt_Protocol、Txt_SocketSizeText、Txt_SwitchSizeText、Txt_ProjectName时 Select Case childShape.Name.ToLower Case "Txt_EnglishFont".ToLower nodeText = $"{bProject.en_font} {bProject.en_font_size.ToString}PT" hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) '移动到childShape对象中心位置 hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_SocketSeries".ToLower nodeText = bProject.socket_series hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_ChineseFont".ToLower nodeText = $"{bProject.cn_font} {bProject.cn_font_size.ToString}PT" hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_SwitchSeries".ToLower nodeText = bProject.switch_series hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_Data".ToLower nodeText = node.RecordDate hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_Protocol".ToLower nodeText = bProject.protocol hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_SocketSizeText".ToLower nodeText = bProject.SocketSizeText.Replace("_", vbCrLf) hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_SwitchSizeText".ToLower nodeText = bProject.SwitchSizeText.Replace("_", vbCrLf) hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY Case "Txt_ProjectName".ToLower nodeText = bProject.project_name hotelnodeText = CreateTextImage2(doc.ActiveLayer, nodeText, remark) hotelnodeText.Fill.ApplyUniformFill(chpcolor) hotelnodeText.CenterX = childShape.CenterX hotelnodeText.CenterY = childShape.CenterY End Select Next Else RsNode.Status = RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = $"未找到文件{vbCrLf}{overviewFilePath}{vbCrLf}中的图像!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ RsNode.Msg}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) doc.Close() Return End If End If InpotMessage1("4、标题信息处理完成") InpotMessage1("5、数据分组处理") ' 设置起始坐标：Project_Title对象的左边值作为起始X，下边值+50mm作为起始Y Dim startX As Double = projectTitleShape.LeftX Dim startY As Double = projectTitleShape.BottomY - 50 ' 起始Y坐标：Project_Title对象的下边值+50mm Dim Panelli As List(Of Panel) Dim roomGroups As Dictionary(Of String, List(Of Panel)) = New Dictionary(Of String, List(Of Panel))() For Each panel As Panel In node.panels If Not roomGroups.ContainsKey(panel.room_name) Then Panelli = New List(Of Panel)() roomGroups.Add(panel.room_name, Panelli) Else Panelli = roomGroups(panel.room_name) End If 'roomGroups(panel.room_name).Add(panel) SortPanelListBySize(Panelli, panel) Console.WriteLine($"添加面板：{panel.room_name} - {panel.model_type}") Next InpotMessage1("6、房型分类处理") currentY = startY ' 设置当前Y坐标为起始Y For Each roomName As String In roomGroups.Keys InpotMessage1("创建房型标题文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = "创建酒店房型标题失败!!" remark = {"思源黑体", "38"} Dim roomText As Shape = CreateTextImage2(doc.ActiveLayer, roomName, remark) roomText.CenterY = currentY roomText.LeftX = startX ' 房型标题左对齐到起始X ' 房型标题下方留出空间 currentY = roomText.CenterY - (roomText.OriginalHeight / 2) - 10 Dim currentX As Double = startX + 50 ' 当前行的X坐标，行左边距50mm Dim maxHeight As Double = 0 ' 当前行最高面板高度 Dim rowWidth As Double = 0 ' 当前行已排布宽度 Dim firstPanelInRow As Boolean = True ' 是否是行内第一个面板 InpotMessage1("遍历该房型对应的所有panel") For Each panel As Panel In roomGroups(roomName) Dim cdr_filename As String = $"{filedir}\{panel.cdr_filename}".Replace("\\", "\") InpotMessage1("7、CDR文件图像处理") If File.Exists(cdr_filename) Then InpotMessage1("打开CDR文件") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"拷贝文件{vbCrLf}{cdr_filename}{vbCrLf}中的面板图像失败!!" Dim cdrDoc As Document = APP.OpenDocument(cdr_filename, False) If cdrDoc.Pages.Count > 0 AndAlso cdrDoc.Pages(1).ActiveLayer.Shapes.Count > 0 Then InpotMessage1("复制第一个图像") Dim cdrShape As Shape = cdrDoc.Pages(1).ActiveLayer.Shapes(1) 'cdrShape.Copy() shapeCopy(cdrShape) InpotMessage1("粘贴到当前文档") Dim pastedShape As Shape = doc.ActiveLayer.Paste() 'doc.ActiveLayer.Shapes(doc.ActiveLayer.Shapes.Count) '延时(500) Thread.Sleep(100) pastedShape.Name = $"{roomName}_{ pastedShape.Name }" ' 计算面板宽度 Dim panelWidth As Double = pastedShape.SizeWidth ' 检查是否需要换行（当前行已排布宽度 + 新面板宽度 + 间距 > 1300mm） If Not firstPanelInRow AndAlso (rowWidth + panelWidth + 50) > 1250 Then ' 换行：换行间距30mm+上一行最高面板高度 currentY = currentY - maxHeight - 30 currentX = startX + 50 ' 重置X坐标到行左边距 maxHeight = 0 ' 重置最大高度 rowWidth = 0 ' 重置行宽度 firstPanelInRow = True ' 重置为行内第一个面板 End If InpotMessage1("设置图像位置") pastedShape.LeftX = currentX pastedShape.CenterY = currentY - (pastedShape.OriginalHeight / 2) InpotMessage1("8、属性文本生成") InpotMessage1("生成panel_list_name文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"生成名称文本图像失败：{panel.panel_list_name} !!" remark = {"思源黑体", "24"} Dim listNameText As Shape = CreateTextImage2(doc.ActiveLayer, "名称：" & panel.panel_list_name, remark) Dim textY As Double = pastedShape.CenterY - (pastedShape.OriginalHeight / 2) - 10 listNameText.CenterY = textY listNameText.LeftX = currentX 'Dim listNameText As Shape = doc.ActiveLayer.CreateArtisticText(currentX, textY, "名称：" & panel.panel_list_name) 'With listNameText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 12 'End With InpotMessage1("生成position文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"生成位置文本图像失败：{panel.position} !!" Dim positionText As Shape = CreateTextImage2(doc.ActiveLayer, "位置：" & panel.position, remark) textY = listNameText.CenterY - (listNameText.OriginalHeight / 2) - 10 positionText.CenterY = textY positionText.LeftX = currentX 'Dim positionText As Shape = doc.ActiveLayer.CreateArtisticText(currentX, textY + 10, "位置：" & panel.position) 'With positionText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 12 'End With InpotMessage1("生成carving_quantity文本") RsNode.Status = RedisSendNode.StatusType.BuildImageFail RsNode.Msg = $"生成数量文本图像失败：{panel.carving_quantity} !!" Dim quantityText As Shape = CreateTextImage2(doc.ActiveLayer, "数量：" & panel.carving_quantity, remark) textY = positionText.CenterY - (positionText.OriginalHeight / 2) - 10 quantityText.CenterY = textY quantityText.LeftX = currentX 'Dim quantityText As Shape = doc.ActiveLayer.CreateArtisticText(currentX, textY + 20, "数量：" & panel.carving_quantity) 'With quantityText.Text.Properties ' .Font = "Source Han Sans SC" ' .Size = 12 'End With InpotMessage1("9、图文组合") pastedShape.Selected = True listNameText.Selected = True positionText.Selected = True quantityText.Selected = True Dim group As Shape = doc.SelectionRange.Group() group.Name = pastedShape.Name 'Path.GetFileNameWithoutExtension(panel.cdr_filename) group.Selected = False pastedShape.Selected = False listNameText.Selected = False positionText.Selected = False quantityText.Selected = False InpotMessage1("计算当前行的最大高度") If group.OriginalHeight > maxHeight Then maxHeight = group.OriginalHeight End If InpotMessage1("更新行宽度和X坐标") If firstPanelInRow Then rowWidth = panelWidth firstPanelInRow = False Else rowWidth += panelWidth + 50 ' 行内面板间距50mm End If currentX += panelWidth + 50 ' 更新X坐标，为下一个面板留出50mm间距 Else RsNode.Status = RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = $"未找到文件{vbCrLf}{cdr_filename}{vbCrLf}中的图像!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ RsNode.Msg}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If InpotMessage1("关闭CDR文件") cdrDoc.Close() Else RsNode.Status = RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = $"文件{vbCrLf}{cdr_filename}{vbCrLf}不存在!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ RsNode.Msg}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If Next ' 更新Y坐标，为下一个房型留出50mm间距 currentY = currentY - maxHeight - 20 Next InpotMessage1("10、文档保存") RsNode.Status = RedisSendNode.StatusType.SaveFileFail RsNode.Msg = $"生成文件失败 !!" Dim savePath As String = $"{filedir}\{hotelName}\{Now:yyyyMMdd}" If Not Directory.Exists(savePath) Then Directory.CreateDirectory(savePath) End If ''判断kuang_lin是否为空 If kuang_lin IsNot Nothing Then Dim heigth As Double = kuang_lin.TopY - currentY + 50 Dim kuang_linTopY As Double = kuang_lin.TopY kuang_lin.SizeHeight = heigth kuang_lin.TopY = kuang_linTopY 'kuang_lin.TransformationMatrix.Rotate() '' 可选：设置变换原点的可见性 'kuang_lin.TransformationOriginVisible = True End If Dim cdrFileName As String = $"{node.picNum}.cdr" Dim cdrFilePath As String = Path.Combine(savePath, cdrFileName) Dim ssao As New StructSaveAsOptions ssao.Filter = VGCore.cdrFilter.cdrCDR ssao.Range = VGCore.cdrExportRange.cdrAllPages ssao.Version = VGCore.cdrFileVersion.cdrVersion19 doc.SaveAs(cdrFilePath, ssao) Dim nngroup As Shape = doc.Pages(1).ActiveLayer.Shapes.All.Group() nngroup.Selected = True Dim ptfFilePath As String = cdrFilePath.Replace(".cdr", ".pdf") 'Dim pngFilePath As String = cdrFilePath.Replace(".cdr", ".png") 'Dim Ef As ExportFilter = doc.ExportBitmap(pngFilePath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) 'Ef.Finish() 'Dim Options As New StructExportOptions 'Dim PaletteOptions As New StructPaletteOptions doc.PublishToPDF(ptfFilePath) 'Ef = doc.ExportEx(ptfFilePath, VGCore.cdrFilter.cdrPPF, VGCore.cdrExportRange.cdrSelection, Options, PaletteOptions) 'Ef.Finish() 'InpotMessage1("9、文档导出") 'Dim pltFileName As String = $"PreviewRoomTypePanel{node.picNum}.plt" 'Dim pltFilePath As String = Path.Combine(savePath, pltFileName) 'doc.Export(pltFilePath, cdrExportFileFormat.cdrPLT) InpotMessage1("关闭文档") doc.Close() RsNode.Status = RedisSendNode.StatusType.Success RsNode.Msg = "Ok" RsNode.CdrPath = cdrFilePath.Replace(filedir & "\", "") RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) InpotMessage1($"11、向Redis写入生成成功信息") gLogNode = New LogNode($"成功生成酒店房间面板预览文档：{cdrFilePath}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) Return Catch ex As Exception RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"生成酒店房间面板预览文档失败：{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) End Try End Sub ''' ''' 检测图库文件命名及内容是否符合规范 ''' ''' 图库文件路径 ''' 错误信息输出 ''' 是否符合规范 Public Function CheckLibraryFile(ByVal filePath As String, ByRef errorMessage As String) As Boolean Dim srcDoc As Document Try ' 获取文件名（不含路径和扩展名） Dim fileName As String = Path.GetFileNameWithoutExtension(filePath) ' 分割文件名 Dim fileParts() As String = fileName.Split("_") ' 检查文件名基本格式 If fileParts.Length < 5 Then errorMessage = "文件名格式错误：必须包含公司_系列_库名_版本_备注" Return False End If ' 检查库名 Dim libName As String = fileParts(2) If libName <> "图标图库" AndAlso libName <> "模型图库" Then errorMessage = "库名错误：只能为'图标图库'或'模型图库'" Return False End If ' 打开文件获取图像名称 srcDoc = APP.OpenDocument(filePath, False) Dim imageNames As New List(Of Shape) ' 遍历所有页、图层和形状获取图像名称 For Each nPage As Page In srcDoc.Pages For Each Layer As Layer In nPage.Layers For Each Shape As Shape In Layer.Shapes If Not String.IsNullOrEmpty(Shape.Name) Then imageNames.Add(Shape) End If Next Next Next ' 遍历检查每个图像名称 For Each imageName As Shape In imageNames If Not CheckImageName(imageName, libName, errorMessage) Then Return False End If Next ' 关闭文件 srcDoc.Close() errorMessage = "" Return True Catch ex As Exception ' 关闭文件 If srcDoc IsNot Nothing Then srcDoc.Close() End If errorMessage = "文件处理错误：" & ex.Message Return False End Try End Function ''' ''' 将Panel按照最小高度优先、最小宽度优先的顺序插入到List(Of Panel)中并重新排序 ''' ''' 要排序的Panel列表 ''' 要插入的新Panel ''' 排序后的Panel列表 Public Shared Function SortPanelListBySize(ByRef panelList As List(Of Panel), ByVal newPanel As Panel) As List(Of Panel) ' 创建列表副本，避免修改原始列表 ' 添加新Panel到列表 ' 定义一个函数来从model_type中提取宽度和高度 Dim getSize As Func(Of Panel, Tuple(Of Double, Double)) = Function(panel) If String.IsNullOrEmpty(panel.model_type) Then Return Tuple.Create(0.0, 0.0) End If Dim parts() As String = panel.model_type.Split("_") If parts.Length < 6 Then Return Tuple.Create(0.0, 0.0) End If Dim width As Double = 0.0 Dim height As Double = 0.0 Double.TryParse(parts(parts.Length - 2), width) Double.TryParse(parts(parts.Length - 1), height) Return Tuple.Create(width, height) End Function If panelList.Count = 0 Then panelList.Add(newPanel) Return panelList End If Dim currentSize, newSize As Tuple(Of Double, Double) For i As Integer = 0 To panelList.Count - 1 '取得当前Panel的宽度和高 currentSize = getSize(panelList(i)) '取得新Panel的宽度和高 newSize = getSize(newPanel) '比较高度 高度低的在前 If currentSize.Item2 > newSize.Item2 Then panelList.Insert(i, newPanel) End If Next ' 如果没有找到合适的位置，则将新Panel添加到列表末尾 If Not panelList.Contains(newPanel) Then panelList.Add(newPanel) End If Return panelList End Function ''' ''' 检查单个图像名称是否符合规范 ''' ''' 图像名称 ''' 图库类型 ''' 错误信息输出 ''' 是否符合规范 Private Function CheckImageName(imageName As Shape, ByVal libName As String, ByRef errorMessage As String) As Boolean ' 分割图像名称 Dim parts() As String = imageName.Name.Split("_") If parts.Length < 2 Then errorMessage = $"图像名称'{imageName.Name}'格式错误：缺少必要部分" Return False End If Dim imageType As String = parts(0).ToLower() Select Case libName Case "模型图库" Return CheckModelLibraryImage(imageType, parts, imageName, errorMessage) Case "图标图库" Return CheckIconLibraryImage(imageType, parts, imageName.Name, errorMessage) Case Else errorMessage = $"未知图库类型：{libName}" Return False End Select End Function ''' ''' 检查模型图库图像名称 ''' Private Function CheckModelLibraryImage(ByVal imageType As String, ByVal parts() As String, imageName As Shape, ByRef errorMessage As String) As Boolean Dim snode As String() Select Case imageType Case "mode" ' Mode_连体数_方向_颜色_宽_高 If parts.Length < 6 Then errorMessage = $"Mode图像'{imageName.Name}'格式错误：必须为Mode_N连体_方向_颜色_宽_高" Return False End If ' 检查连体数格式 If Not parts(1).EndsWith("连体") Then errorMessage = $"Mode图像'{imageName.Name}'连体数格式错误：必须包含'连体'" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(parts(4)) OrElse Not IsNumeric(parts(5)) Then errorMessage = $"Mode图像'{imageName.Name}'宽高格式错误：必须为数字" Return False End If For Each imageNamenode As Shape In imageName.Shapes snode = imageNamenode.Name.Split("_") Select Case snode(0).ToLower() Case "effect" ' Effect_效果名称_w_h If snode.Length < 4 Then errorMessage = $"Effect图像'{imageNamenode.Name}'格式错误：必须为Effect_效果名称_w_h" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(snode(snode.Length - 2)) OrElse Not IsNumeric(snode(snode.Length - 1)) Then errorMessage = $"Effect图像'{imageNamenode.Name}'宽高格式错误：必须为数字" Return False End If Return True Case "logo" ' Logo_图像类型_左右_宽_高 If snode.Length < 5 Then errorMessage = $"Logo图像'{imageNamenode.Name}'格式错误：必须为Logo_图像类型_左右(L/R)_宽_高" Return False End If ' 检查左右标识 If snode(2) <> "L" AndAlso snode(2) <> "R" Then errorMessage = $"Logo图像'{imageNamenode.Name}'左右标识错误：只能为L或R" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(snode(3)) OrElse Not IsNumeric(snode(4)) Then errorMessage = $"Logo图像'{imageNamenode.Name}'宽高格式错误：必须为数字" Return False End If Return True Case "iconb" ' IconB_N连体_方向_颜色_宽_高 If snode.Length < 6 Then errorMessage = $"IconB图像'{imageNamenode.Name}'格式错误：必须为IconB_N连体_方向_颜色_宽_高" Return False End If ' 检查连体数格式 If Not snode(1).EndsWith("连体") Then errorMessage = $"IconB图像'{imageNamenode.Name}'连体数格式错误：必须包含'连体'" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(snode(4)) OrElse Not IsNumeric(snode(5)) Then errorMessage = $"IconB图像'{imageNamenode.Name}'宽高格式错误：必须为数字" Return False End If Return True Case "trench" ' Trench_槽位编号_w_h If snode.Length < 4 Then errorMessage = $"Trench图像'{imageNamenode.Name}'格式错误：必须为Trench_槽位编号_w_h" Return False End If ' 检查槽位编号是否为数字 If Not IsNumeric(snode(1)) Then errorMessage = $"Trench图像'{imageNamenode.Name}'槽位编号错误：必须为数字" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(snode(2)) OrElse Not IsNumeric(snode(3)) Then errorMessage = $"Trench图像'{imageNamenode.Name}'宽高格式错误：必须为数字" Return False End If End Select Next Return True Case "mono" ' Mono_图像名称_w_h If parts.Length < 4 Then errorMessage = $"Mono图像'{imageName.Name}'格式错误：必须为Mono_图像名称_w_h" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(parts(parts.Length - 2)) OrElse Not IsNumeric(parts(parts.Length - 1)) Then errorMessage = $"Mono图像'{imageName.Name}'宽高格式错误：必须为数字" Return False End If For Each imageNamenode In imageName.Shapes snode = imageNamenode.Name.Split("_") Select Case snode(0) Case "location" ' location_图像类型_按键序号_w_h 或 location_图像类型_按键序号_w_h_行号 If snode.Length < 5 OrElse snode.Length > 6 Then errorMessage = $"Location图像'{imageNamenode.Name}'格式错误：必须为location_图像类型_按键序号_w_h[_行号]" Return False End If ' 检查按键序号是否为数字 If Not IsNumeric(snode(2)) Then errorMessage = $"Location图像'{imageNamenode.Name}'按键序号错误：必须为数字" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(snode(3)) OrElse Not IsNumeric(snode(4)) Then errorMessage = $"Location图像'{imageNamenode.Name}'宽高格式错误：必须为数字" Return False End If ' 如果有行号，检查是否为数字 If snode.Length = 6 AndAlso Not IsNumeric(snode(5)) Then errorMessage = $"Location图像'{imageNamenode.Name}'行号错误：必须为数字" Return False End If End Select Next Return True Case Else Return True errorMessage = $"模型图库中包含未知图像类型：{imageType}" Return False End Select End Function ''' ''' 检查图标图库图像名称 ''' Private Function CheckIconLibraryImage(ByVal imageType As String, ByVal parts() As String, ByVal imageName As String, ByRef errorMessage As String) As Boolean Select Case imageType Case "icon" ' Icon_图像名称_图像英文名称_w_h If parts.Length < 5 Then errorMessage = $"Icon图像'{imageName}'格式错误：必须为Icon_图像名称_图像英文名称_w_h" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(parts(parts.Length - 2)) OrElse Not IsNumeric(parts(parts.Length - 1)) Then errorMessage = $"Icon图像'{imageName}'宽高格式错误：必须为数字" Return False End If Return True Case "logo" ' Logo_图像名称_w_h If parts.Length > 5 OrElse parts.Length < 4 Then errorMessage = $"Logo图像'{imageName}'格式错误：必须为Logo_图像名称_图像英文名称_w_h" Return False End If ' 检查宽高是否为数字 If Not IsNumeric(parts(parts.Length - 2)) OrElse Not IsNumeric(parts(parts.Length - 1)) Then errorMessage = $"Logo图像'{imageName}'宽高格式错误：必须为数字" Return False End If Return True Case Else errorMessage = $"图标图库中包含未知图像类型：{imageType}" Return False End Select End Function Public Function HandleNodeInformation1(node As RedisInfoNode) As Boolean Dim oldTime As DateTime = Now Dim MaterialPath As String = M_MaterialPath & node.MaterialLibraryName Dim RsNode As New RedisSendNode RsNode.User = node.User RsNode.ProjectName = node.ProjectName RsNode.ProjectId = node.ProjectId RsNode.PictureNum = node.PictureNum RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Process = node.Process RsNode.Guid = node.Guid Dim gLogNode As LogNode Dim ProjectPath As String Dim locionbuf(), indexbuf() As String Dim shp, lhp, rhp, chp, clhp As Shape Dim x#, y#, w#, h# Dim dx As Double, dy As Double Dim destLayer As Layer '''Console.WriteLine($"到达节点1耗时：{(Now - oldTime).TotalMilliseconds}毫秒") '查找素材库 If Not File.Exists(MaterialPath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = "素材库不存在!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) gLogNode = New LogNode("素材库不存在", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If '''Console.WriteLine($"到达节点2耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Try Try G_LibDoc = APP.OpenDocument(MaterialPath, False) Catch ex As Exception APP = New Application() Thread.Sleep(500) APP.Visible = False G_LibDoc = APP.OpenDocument(MaterialPath, False) End Try ProjectPath = $"{M_TplPath}{node.ProjectName}\{Now:yyyyMMdd}" '判断项目文件夹是否存在 If Not Directory.Exists(ProjectPath) Then 'MsgBox("项目文件夹不存在") '创建文件夹 Directory.CreateDirectory(ProjectPath) End If '查找模板 locionbuf = node.TemplateNameIndex.Split("_") Dim page As Page = G_LibDoc.Pages(CInt(locionbuf(0))) '''Console.WriteLine($"到达节点8耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim layer As Layer = page.Layers(CInt(locionbuf(1))) '''Console.WriteLine($"到达节点7耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shp = layer.Shapes(CInt(locionbuf(2))) '''Console.WriteLine($"到达节点6耗时：{(Now - oldTime).TotalMilliseconds}毫秒") If IsNothing(shp) OrElse Not node.TemplateName.Trim.Equals(shp.Name.Trim) Then RsNode.Status = RedisSendNode.StatusType.TemplateNotExist RsNode.Msg = "未找到模板信息！！" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) gLogNode = New LogNode("未找到模板信息！！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If '''Console.WriteLine($"到达节点3耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim li As New List(Of (Shape, Shape)) Dim ctdic As New List(Of (Shape, Shape)) '遍历node.MaterialDic For Each item In node.PatternList '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") indexbuf = item.ShapeNumber.Split("_") RsNode.Status = RedisSendNode.StatusType.MaterialPositionNotExist lhp = shp.Shapes(CInt(item.IndexNumber)) RsNode.Status = RedisSendNode.StatusType.MaterialNotExist page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) rhp = layer.Shapes(CInt(indexbuf(2))) '单体先挪到槽位 x = lhp.CenterX - rhp.CenterX y = lhp.CenterY - rhp.CenterY dx = lhp.LeftX dy = lhp.TopY rhp.Move(x, y) clhp = rhp.Shapes(rhp.Shapes.Count) clhp.Visible = False li.Add((rhp, lhp)) '再将素材挪到指定的小槽位 For Each LocationNode In item.LocationList clhp = rhp.Shapes(CInt(LocationNode.IndexNumber)) indexbuf = LocationNode.ShapeNumber.Split("_") page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) chp = layer.Shapes(CInt(indexbuf(2))) x = clhp.CenterX - chp.CenterX y = clhp.CenterY - chp.CenterY dx = clhp.LeftX dy = clhp.TopY chp.Move(x, y) ctdic.Add((chp, clhp)) Next Next '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") RsNode.Status = RedisSendNode.StatusType.BuildImageFail shp.Selected = True For Each item In li item.Item1.OrderToFront() item.Item1.Selected = True ''Console.WriteLine(item.Item2.Name) item.Item2.Delete() Next For Each item In ctdic item.Item1.OrderToFront() item.Item1.Selected = True item.Item2.Delete() Next '''Console.WriteLine($"到达节点4耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim sr As ShapeRange = APP.ActiveSelectionRange shp = sr.Group() shp.Name = node.TemplateName page = G_LibDoc.Pages(CInt(locionbuf(0))) SetIconToCentered(page, shp) '''Console.WriteLine($"到达节点11耗时：{(Now - oldTime).TotalMilliseconds}毫秒") RsNode.Status = RedisSendNode.StatusType.SaveFileFail shp.Selected = True 'Dim sel As ShapeRange = APP.ActiveSelectionRange '0-预览小图 1-生成文件 Select Case node.Process Case 0 ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.png" Dim Ef As ExportFilter = G_LibDoc.ExportBitmap(ProjectPath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() Case 1 ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.cdr" Dim ssao As New StructSaveAsOptions ssao.Filter = VGCore.cdrFilter.cdrCDR ssao.Range = VGCore.cdrExportRange.cdrSelection G_LibDoc.SaveAs(ProjectPath, ssao) Case Else G_LibDoc.Close() RsNode.Status = RedisSendNode.StatusType.UnknownFail RsNode.Msg = "位置操作!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) Return False End Select G_LibDoc.Close() RsNode.Status = RedisSendNode.StatusType.Success RsNode.Msg = "Ok" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) Return True Catch ex As Exception Select Case RsNode.Status Case RedisSendNode.StatusType.MaterialPositionNotExist RsNode.Msg = "素材位置不存在!!" Case RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = "素材不存在!!" Case RedisSendNode.StatusType.BuildImageFail RsNode.Msg = "生成图像失败!!" Case RedisSendNode.StatusType.SaveFileFail RsNode.Msg = "保存文件失败!!" End Select RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) If Not IsNothing(G_LibDoc) Then G_LibDoc.Close() End If gLogNode = New LogNode($"{RsNode.Msg}{vbCrLf}{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End Try End Function Public Function HandleNodeInformation2(node As RedisInfoNode) As Boolean Dim oldTime As DateTime = Now Dim MaterialPath As String = M_MaterialPath & node.MaterialLibraryName Dim RsNode As New RedisSendNode RsNode.User = node.User RsNode.ProjectName = node.ProjectName RsNode.ProjectId = node.ProjectId RsNode.PictureNum = node.PictureNum RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Process = node.Process RsNode.Guid = node.Guid Dim gLogNode As LogNode Dim ProjectPath As String Dim locionbuf(), indexbuf() As String Dim fshp, shp, lhp, rhp, chp, clhp As Shape Dim x#, y#, w#, h# Dim dx As Double, dy As Double Dim destLayer As Layer Dim MLibDoc As Document Dim ServerFilePath As String = "D:\BLWLog\Web\wwwroot\PanelSelectionPic\" '''Console.WriteLine($"到达节点1耗时：{(Now - oldTime).TotalMilliseconds}毫秒") '查找素材库 If Not File.Exists(MaterialPath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = "素材库不存在!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) gLogNode = New LogNode("素材库不存在", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If '''Console.WriteLine($"到达节点2耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Try Try G_LibDoc = APP.OpenDocument(MaterialPath, False) MLibDoc = APP.CreateDocument() Catch ex As Exception APP = New Application() Thread.Sleep(1000) APP.Visible = False G_LibDoc = APP.OpenDocument(MaterialPath, False) MLibDoc = APP.CreateDocument() End Try APP.EventsEnabled = False APP.Optimization = True 'APP.EventsEnabled = True 'APP.Optimization = False 'APP.Refresh() ProjectPath = $"{ServerFilePath}{node.ProjectName}\{Now:yyyyMMdd}" '判断项目文件夹是否存在 If Not Directory.Exists(ProjectPath) Then 'MsgBox("项目文件夹不存在") '创建文件夹 Directory.CreateDirectory(ProjectPath) End If '查找模板 locionbuf = node.TemplateNameIndex.Split("_") Dim npage As Page Dim page As Page = G_LibDoc.Pages(CInt(locionbuf(0))) '''Console.WriteLine($"到达节点8耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim layer As Layer = page.Layers(CInt(locionbuf(1))) Dim nlayer As Layer '''Console.WriteLine($"到达节点7耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shp = layer.Shapes(CInt(locionbuf(2))) '''Console.WriteLine($"到达节点6耗时：{(Now - oldTime).TotalMilliseconds}毫秒") If IsNothing(shp) OrElse Not node.TemplateName.Trim.Equals(shp.Name.Trim) Then RsNode.Status = RedisSendNode.StatusType.TemplateNotExist RsNode.Msg = "未找到模板信息！！" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) gLogNode = New LogNode("未找到模板信息！！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False Else '将模板复制到新文档 '''Console.WriteLine($"到达节点5耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ''Console.WriteLine($"到达节点1耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shapeCopy(shp) npage = MLibDoc.Pages(1) nlayer = MLibDoc.ActiveLayer ''Console.WriteLine($"到达节点2耗时：{(Now - oldTime).TotalMilliseconds}毫秒") fshp = nlayer.Paste() ''Console.WriteLine($"到达节点3耗时：{(Now - oldTime).TotalMilliseconds}毫秒") End If '''Console.WriteLine($"到达节点3耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim li As New List(Of (Shape, Shape)) Dim ctdic As New List(Of (Shape, Shape)) Dim Uctdic As New Dictionary(Of Integer, List(Of Shape）) '遍历node.MaterialDic For Each item In node.PatternList ' ''Console.WriteLine(item.ShapeNumber) '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") indexbuf = item.ShapeNumber.Split("_") RsNode.Status = RedisSendNode.StatusType.MaterialPositionNotExist lhp = fshp.Shapes(CInt(item.IndexNumber)) RsNode.Status = RedisSendNode.StatusType.MaterialNotExist page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) rhp = layer.Shapes(CInt(indexbuf(2))) '延时20个毫秒 ''Console.WriteLine(rhp.Name) ''Console.WriteLine($"到达节点4耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shapeCopy(rhp) ''Console.WriteLine($"到达节点5耗时：{(Now - oldTime).TotalMilliseconds}毫秒") rhp = nlayer.Paste() ''Console.WriteLine($"到达节点6耗时：{(Now - oldTime).TotalMilliseconds}毫秒") rhp.Name = rhp.Name & "_" & item.IndexNumber '单体先挪到槽位 li.Add((rhp, lhp)) '再将素材挪到指定的小槽位 For Each LocationNode In item.LocationList ''Console.WriteLine(LocationNode.ShapeNumber) If LocationNode.ShapeType = 0 Then Dim remark As String() = LocationNode.Remark.Split("_") If remark.Length > 1 Then clhp = rhp.Shapes(CInt(LocationNode.IndexNumber)) chp = CreateTextImage(nlayer, LocationNode.ShapeNumber, remark) If IsNothing(chp) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = "生成文本图像失败!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) gLogNode = New LogNode("生成文本图像失败！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If chp.Name = chp.Name & "_" & item.IndexNumber & "_" & LocationNode.IndexNumber ctdic.Add((chp, clhp)) If remark.Length > 2 Then Dim chpli As List(Of Shape) If Uctdic.ContainsKey(remark(2)) Then chpli = Uctdic(remark(2)) chpli.Add(chp) Else chpli = New List(Of Shape) chpli.Add(chp) Uctdic.Add(remark(2), chpli) End If End If Else RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = "生成文本图像失败!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) gLogNode = New LogNode("生成文本图像失败!", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If Else clhp = rhp.Shapes(CInt(LocationNode.IndexNumber)) indexbuf = LocationNode.ShapeNumber.Split("_") page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) chp = layer.Shapes(CInt(indexbuf(2))) '延时10个毫秒 '延时20个毫秒 ''Console.WriteLine($"到达节点7耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ''Console.WriteLine(chp.Name) '延时50ms ''Console.WriteLine($"到达节点8耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shapeCopy(chp) ''Console.WriteLine($"到达节点9耗时：{(Now - oldTime).TotalMilliseconds}毫秒") chp = nlayer.Paste() ''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") chp.Name = chp.Name & "_" & item.IndexNumber & "_" & LocationNode.IndexNumber ctdic.Add((chp, clhp)) End If Next ''Console.WriteLine(rhp.Name) Next '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") RsNode.Status = RedisSendNode.StatusType.BuildImageFail 'fshp.Selected = True For Each item In li item.Item1.OrderToFront() x = item.Item2.CenterX - item.Item1.CenterX y = item.Item2.CenterY - item.Item1.CenterY item.Item1.Move(x, y) clhp = item.Item1.Shapes(item.Item1.Shapes.Count) clhp.Visible = False ' li.Add((rhp, lhp)) 'item.Item1.Selected = True ''Console.WriteLine(item.Item2.Name) item.Item2.Delete() Next For Each item In ctdic item.Item1.OrderToFront() x = item.Item2.CenterX - item.Item1.CenterX y = item.Item2.CenterY - item.Item1.CenterY item.Item1.Move(x, y) 'ctdic.Add((chp, clhp)) 'item.Item1.Selected = True item.Item2.Delete() Next Dim topl As Single = 0 For Each item In Uctdic For i = 0 To item.Value.Count - 1 If i = 0 Then topl = item.Value(0).TopY End If item.Value(i).TopY = topl Next Next '''Console.WriteLine($"到达节点4耗时：{(Now - oldTime).TotalMilliseconds}毫秒") 'Dim sr As ShapeRange = APP.ActiveSelectionRange fshp = nlayer.Shapes.All().Group() 'shp = sr.Group() fshp.Name = node.TemplateName 'page = G_LibDoc.Pages(CInt(locionbuf(0))) 'SetIconToCentered(page, shp) '''Console.WriteLine($"到达节点11耗时：{(Now - oldTime).TotalMilliseconds}毫秒") RsNode.Status = RedisSendNode.StatusType.SaveFileFail fshp.Selected = True SetIconToCentered(npage, fshp) 'Dim sel As ShapeRange = APP.ActiveSelectionRange '0-预览小图 1-生成文件 Select Case node.Process Case 0 ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.png" Dim Ef As ExportFilter = MLibDoc.ExportBitmap(ProjectPath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() RsNode.ImagePath = ProjectPath.Replace(ServerFilePath, "") Case 1 ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.cdr" Dim ssao As New StructSaveAsOptions ssao.Filter = VGCore.cdrFilter.cdrCDR ssao.Range = VGCore.cdrExportRange.cdrSelection MLibDoc.SaveAs(ProjectPath, ssao) RsNode.CdrPath = ProjectPath.Replace(ServerFilePath, "") Case Else MLibDoc.Close() G_LibDoc.Close() RsNode.Status = RedisSendNode.StatusType.UnknownFail RsNode.Msg = "位置操作!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) Return False End Select APP.EventsEnabled = True APP.Optimization = False APP.Refresh() MLibDoc.Close() G_LibDoc.Close() RsNode.Status = RedisSendNode.StatusType.Success RsNode.Msg = "Ok" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) Return True Catch ex As Exception APP.EventsEnabled = True APP.Optimization = False APP.Refresh() Select Case RsNode.Status Case RedisSendNode.StatusType.MaterialPositionNotExist RsNode.Msg = "素材位置不存在!!" Case RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = "素材不存在!!" Case RedisSendNode.StatusType.BuildImageFail RsNode.Msg = "生成图像失败!!" Case RedisSendNode.StatusType.SaveFileFail RsNode.Msg = "保存文件失败!!" End Select RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RsNode)) If Not IsNothing(MLibDoc) Then MLibDoc.Close() End If If Not IsNothing(G_LibDoc) Then G_LibDoc.Close() End If gLogNode = New LogNode($"{RsNode.Msg}{vbCrLf}{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End Try End Function '输出日志 Public Sub InpotMessage1(PictureNum As String) If Isdisply Then Dim gLogNode As LogNode gLogNode = New LogNode(PictureNum, RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Blue) G_Log.AddLogNode(gLogNode) End If End Sub Public Function HandleNodeInformation3(node As RedisInfoNode) As Boolean InpotMessage1("1、开始生成文件") Dim oldTime As DateTime = Now Dim MaterialPath As String = M_MaterialPath & node.MaterialLibraryName Dim RsNode As New RedisSendNode RsNode.User = node.User RsNode.ProjectName = node.ProjectName RsNode.ProjectId = node.ProjectId RsNode.PictureNum = node.PictureNum RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Process = node.Process RsNode.Guid = node.Guid Dim RMNode As New RedisMsgNode RMNode.MsgType = 1 RMNode.MsgNode = RsNode Dim gLogNode As LogNode Dim ProjectPath As String Dim locionbuf(), indexbuf() As String Dim fshp, shp, lhp, rhp, chp, clhp As Shape Dim x#, y#, w#, h# Dim dx As Double, dy As Double Dim destLayer As Layer Dim MLibDoc As Document Dim li As New List(Of (Shape, Shape)) Dim ServerFilePath As String = M_ServerPath '"R:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' "D:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic\" ' '''Console.WriteLine($"到达节点1耗时：{(Now - oldTime).TotalMilliseconds}毫秒") '查找素材库 InpotMessage1("2、检测模版素材库是否存在") If Not File.Exists(MaterialPath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = "模版素材库不存在!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode("模版素材库不存在", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If '''Console.WriteLine($"到达节点2耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Try Try G_LibDoc = APP.OpenDocument(MaterialPath, False) MLibDoc = APP.CreateDocument() InpotMessage1("3、打开模板库并创建新文件等待构建图像") Catch ex As Exception APP = New Application() Thread.Sleep(1000) APP.Visible = False G_LibDoc = APP.OpenDocument(MaterialPath, True) MLibDoc = APP.CreateDocument() End Try APP.EventsEnabled = False APP.Optimization = True 'APP.EventsEnabled = True 'APP.Optimization = False 'APP.Refresh() ProjectPath = $"{ServerFilePath}{node.ProjectName}\{Now:yyyyMMdd}" '判断项目文件夹是否存在 InpotMessage1("4、创建项目文件夹") If Not Directory.Exists(ProjectPath) Then 'MsgBox("项目文件夹不存在") '创建文件夹 Directory.CreateDirectory(ProjectPath) End If '查找模板 InpotMessage1("5、开始查找模板图像") locionbuf = node.TemplateNameIndex.Split("_") Dim npage As Page Dim page As Page = G_LibDoc.Pages(CInt(locionbuf(0))) '''Console.WriteLine($"到达节点8耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim layer As Layer = page.Layers(CInt(locionbuf(1))) Dim nlayer As Layer '''Console.WriteLine($"到达节点7耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shp = layer.Shapes(CInt(locionbuf(2))) '''Console.WriteLine($"到达节点6耗时：{(Now - oldTime).TotalMilliseconds}毫秒") If IsNothing(shp) OrElse Not node.TemplateName.Trim.Equals(shp.Name.Trim) Then RsNode.Status = RedisSendNode.StatusType.TemplateNotExist RsNode.Msg = "未找到模板信息！！" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode("未找到模板信息！！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False Else '将模板复制到新文档 '''Console.WriteLine($"到达节点5耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ''Console.WriteLine($"到达节点1耗时：{(Now - oldTime).TotalMilliseconds}毫秒") InpotMessage1("6、开始拷贝模版图像到目标文件") shapeCopy(shp) npage = MLibDoc.Pages(1) nlayer = MLibDoc.ActiveLayer ''Console.WriteLine($"到达节点2耗时：{(Now - oldTime).TotalMilliseconds}毫秒") fshp = nlayer.Paste() InpotMessage1("7、拷贝模版图像到目标文件") If Not String.IsNullOrEmpty(node.LogoPosition) Then MaterialPath = M_MaterialPath & node.LogoFileName If Not File.Exists(MaterialPath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = $"Logo素材库不存在!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"Logo素材库不存在!", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If InpotMessage1("8、查找Logo图像") Dim cshape, vshape As Shape G_LibDoc = APP.OpenDocument(MaterialPath, False) vshape = fshp.Shapes(CInt(node.LogoPosition)) indexbuf = node.LogoIndexNumber.Split("_") page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) cshape = layer.Shapes(CInt(indexbuf(2))) InpotMessage1("9、开始拷贝Logo图像") shapeCopy(cshape) ''Console.WriteLine($"到达节点9耗时：{(Now - oldTime).TotalMilliseconds}毫秒") cshape = nlayer.Paste() ''Console.WriteLine($"到达节点3耗时：{(Now - oldTime).TotalMilliseconds}毫秒") 'Console.WriteLine($"logo:{cshape.Name} 复制完成{ cshape.LeftX},{cshape.TopY}！") InpotMessage1("10、拷贝Logo图像到目标文件") cshape.OrderToFront() vshape.Visible = True vshape.Selected = True x = vshape.CenterX - cshape.CenterX y = vshape.CenterY - cshape.CenterY cshape.Move(x, y) 'cshape.SetPosition(vshape.LeftX, vshape.TopY) 'cshape.SetSize(vshape.SizeWidth, vshape.SizeHeight) 'Dim Stretchbuf As (Double, Double) = GetScale(cshape.SizeWidth, cshape.SizeHeight, vshape.SizeWidth, vshape.SizeHeight) 'cshape.Stretch(Stretchbuf.Item1, Stretchbuf.Item2) Console.WriteLine($"{cshape.Name}_{cshape.CenterX}_{cshape.CenterY}->{vshape.Name}_{vshape.CenterX}_{vshape.CenterY }") InpotMessage1("11、设置Logo图像在目标文件的为位置") li.Add((cshape, vshape)) End If End If '''Console.WriteLine($"到达节点3耗时：{(Now - oldTime).TotalMilliseconds}毫秒") Dim ctdic As New List(Of (Shape, Shape)) Dim Uctdic As New Dictionary(Of Integer, List(Of Shape）) '遍历node.MaterialDic 'APP.EventsEnabled = True 'APP.Optimization = False 'APP.Refresh() InpotMessage1("12、开始构建单体") For Each item In node.PatternList ' ''Console.WriteLine(item.ShapeNumber) '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") MaterialPath = M_MaterialPath & item.FileName If Not File.Exists(MaterialPath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = $"单体素材库不存在!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"单体素材库不存在!", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If InpotMessage1($"打开单体所在文件{vbCrLf}{MaterialPath}") G_LibDoc = APP.OpenDocument(MaterialPath, False) InpotMessage1($"开始查找单体") indexbuf = item.ShapeNumber.Split("_") RsNode.Status = RedisSendNode.StatusType.MaterialPositionNotExist lhp = fshp.Shapes(CInt(item.IndexNumber)) RsNode.Status = RedisSendNode.StatusType.MaterialNotExist page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) rhp = layer.Shapes(CInt(indexbuf(2))) InpotMessage1($"开始拷贝单体{rhp.Name}") '延时20个毫秒 ''Console.WriteLine(rhp.Name) ''Console.WriteLine($"到达节点4耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shapeCopy(rhp) ''Console.WriteLine($"到达节点5耗时：{(Now - oldTime).TotalMilliseconds}毫秒") rhp = nlayer.Paste() ''Console.WriteLine($"到达节点6耗时：{(Now - oldTime).TotalMilliseconds}毫秒") rhp.Name = rhp.Name & "_" & item.IndexNumber '单体先挪到槽位 InpotMessage1($"拷贝单体:{rhp.Name} 到目标文件") li.Add((rhp, lhp)) '再将素材挪到指定的小槽位 For Each LocationNode In item.LocationList ''Console.WriteLine(LocationNode.ShapeNumber) If LocationNode.ShapeType = 0 Then InpotMessage1($"开始创建字体图像:{LocationNode.ShapeNumber} 到目标文件") Dim remark As String() = LocationNode.Remark.Split("_") clhp = rhp.Shapes(CInt(LocationNode.IndexNumber)) chp = CreateTextImage1(nlayer, LocationNode.ShapeNumber, LocationNode) If IsNothing(chp) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = "生成文本图像失败!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode("生成文本图像失败！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If InpotMessage1($"创建字体图像:{LocationNode.ShapeNumber} 到目标文件") chp.Name = chp.Name & "_" & item.IndexNumber & "_" & LocationNode.IndexNumber ctdic.Add((chp, clhp)) If Not String.IsNullOrEmpty(LocationNode.LineNumber) Then Dim chpli As List(Of Shape) Dim LineNumber As Integer = CInt(LocationNode.LineNumber) If Uctdic.ContainsKey(LineNumber) Then chpli = Uctdic(LineNumber) chpli.Add(chp) Else chpli = New List(Of Shape) chpli.Add(chp) Uctdic.Add(LineNumber, chpli) End If End If Else MaterialPath = M_MaterialPath & LocationNode.FileName InpotMessage1($"开始检测素材库文件是否存在:{MaterialPath} ") If Not File.Exists(MaterialPath) Then RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist RsNode.Msg = $"图标素材库不存在!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) gLogNode = New LogNode($"图标素材库不存在!", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End If InpotMessage1($"打开素材库文件:{MaterialPath} ") G_LibDoc = APP.OpenDocument(MaterialPath, False) InpotMessage1($"开始查找素材 ") clhp = rhp.Shapes(CInt(LocationNode.IndexNumber)) indexbuf = LocationNode.ShapeNumber.Split("_") page = G_LibDoc.Pages(CInt(indexbuf(0))) layer = page.Layers(CInt(indexbuf(1))) chp = layer.Shapes(CInt(indexbuf(2))) InpotMessage1($"开始拷贝素材 ") '延时10个毫秒 '延时20个毫秒 '''Console.WriteLine($"到达节点7耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ''Console.WriteLine(chp.Name) '延时50ms ''Console.WriteLine($"到达节点8耗时：{(Now - oldTime).TotalMilliseconds}毫秒") shapeCopy(chp) ''Console.WriteLine($"到达节点9耗时：{(Now - oldTime).TotalMilliseconds}毫秒") chp = nlayer.Paste() InpotMessage1($"拷贝素材 {chp.Name}到目标文件") 'Dim chpcolor As New VGCore.color ' Dim chpcolor As Color = New Color Dim colorint As (Integer, Integer, Integer) = HexToRgb(LocationNode.ShapeColor) chpcolor.RGBAssign(colorint.Item1, colorint.Item2, colorint.Item3) Dim chpcolor1 As IVGColor = chp.Fill.UniformColor chp.Fill.ApplyUniformFill(chpcolor) InpotMessage1($"设置素材 {chp.Name}图像颜色") ''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") chp.Name = chp.Name & "_" & item.IndexNumber & "_" & LocationNode.IndexNumber ctdic.Add((chp, clhp)) End If Next '这里要先把单体移到对应位置 InpotMessage1($"开始设置单体位置") rhp.OrderToFront() lhp.Visible = True x = lhp.CenterX - rhp.CenterX y = lhp.CenterY - rhp.CenterY rhp.Move(x, y) clhp = rhp.Shapes(rhp.Shapes.Count) clhp.Delete() ' = False '将替换的元素移到对应位置 InpotMessage1($"开始设置该单体内的素材图像位置") For Each nitem In ctdic nitem.Item1.OrderToFront() x = nitem.Item2.CenterX - nitem.Item1.CenterX y = nitem.Item2.CenterY - nitem.Item1.CenterY nitem.Item1.Move(x, y) 'ctdic.Add((chp, clhp)) 'item.Item1.Selected = True nitem.Item2.Delete() InpotMessage1($"设置素材{nitem.Item1.Name} 图像位置") Next ctdic.Clear() '对齐 Dim topl As Single = 0 InpotMessage1($"开始设素材图像顶部对齐") For Each Uitem In Uctdic For i = 0 To Uitem.Value.Count - 1 If i = 0 Then topl = Uitem.Value(0).TopY End If Uitem.Value(i).TopY = topl Next Next InpotMessage1($"素材图像顶部对齐完毕") Uctdic.Clear() Next '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") RsNode.Status = RedisSendNode.StatusType.BuildImageFail InpotMessage1($"开始删除单体槽位") For Each mitem In li 'Console.WriteLine(mitem.Item1.Name) 'Console.WriteLine(mitem.Item2.Name) mitem.Item2.Delete() Next InpotMessage1($"单体槽位删除完毕") li.Clear() '''Console.WriteLine($"到达节点4耗时：{(Now - oldTime).TotalMilliseconds}毫秒") 'Dim sr As ShapeRange = APP.ActiveSelectionRange InpotMessage1($"13、开始组合整个图像") fshp = nlayer.Shapes.All().Group() 'shp = sr.Group() fshp.Name = node.TemplateName 'page = G_LibDoc.Pages(CInt(locionbuf(0))) 'SetIconToCentered(page, shp) '''Console.WriteLine($"到达节点11耗时：{(Now - oldTime).TotalMilliseconds}毫秒") RsNode.Status = RedisSendNode.StatusType.SaveFileFail fshp.Selected = True InpotMessage1($"14、开始将整个图像移动至中心位置") SetIconToCentered(npage, fshp) 'Dim sel As ShapeRange = APP.ActiveSelectionRange APP.EventsEnabled = True APP.Optimization = False APP.Refresh() 'fshp.SetSize(Math.Abs(fshp.SizeWidth) * 10000, Math.Abs(fshp.SizeHeight) * 10000) InpotMessage1($"15、开始保存图像成文件") '0-预览小图 1-生成文件 Select Case node.Process Case 0 ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.png" Dim Ef As ExportFilter = MLibDoc.ExportBitmap(ProjectPath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() RsNode.ImagePath = ProjectPath.Replace(ServerFilePath, "") Case 1 For Each shnode In fshp.Shapes '查找名称为Mode_的子节点 If shnode.Name.Contains("Mode_") Then '倒序遍历其子节点 Dim xvbnode As Shape For i = shnode.Shapes.Count To 1 Step -1 xvbnode = shnode.Shapes.Item(i) '将子节点中名称带有Effect _ 的节点删除 If xvbnode.Name.Contains("Effect") Then xvbnode.Delete() End If Next End If Next ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.cdr" Dim ssao As New StructSaveAsOptions ssao.Filter = VGCore.cdrFilter.cdrCDR ssao.Range = VGCore.cdrExportRange.cdrSelection MLibDoc.SaveAs(ProjectPath, ssao) InpotMessage1($"16、保存图像成plt文件") ProjectPath = ProjectPath.Replace(".cdr", ".plt") 'ssao.Filter = VGCore.cdrFilter.cdrPLT 'ssao.Range = VGCore.cdrExportRange.cdrSelection 'MLibDoc.FullFileName = ProjectPath 'MLibDoc.SaveAs(ProjectPath, ssao) 'fshp.SizeWidth = fshp.SizeWidth * 10000 'fshp.SizeHeight = fshp.SizeHeight * 10000 Dim originalUnit As cdrUnit originalUnit = MLibDoc.Unit ' 将文档单位设置为毫米 MLibDoc.Unit = VGCore.cdrUnit.cdrMillimeter '1. 宽高（mm） Dim wMm As Double = Format(fshp.SizeWidth, "0.000") Dim hMm As Double = Format(fshp.SizeHeight, "0.000") fshp.GetSize(wMm, hMm) hMm = (hMm * 100) ' / 304.8 wMm = (wMm * 100) '/ 304.8 'fshp.Scale 'fshp.SizeWidth = wMm 'fshp.SizeHeight = hMm 'fshp.SetSizeEx(fshp.CenterX, fshp.CenterY, wMm, hMm) fshp.SetSize(wMm, hMm) '4. 打印 Console.WriteLine($"宽 : {wMm:F2} mm") Console.WriteLine($"高 : {hMm:F2} mm") 'Console.WriteLine($"X 放大倍数: {scaleX:F2}") 'Console.WriteLine($"Y 放大倍数: {scaleY:F2}") 'Console.WriteLine($"比例锁定 : {locked}") Dim opt As New StructExportOptions opt.MaintainAspect = True 'opt.ResolutionX = 100 'opt.ResolutionY = 100 'opt.SizeX = wMm 'opt.SizeY = hMm opt.AntiAliasingType = VGCore.cdrAntiAliasingType.cdrSupersampling 'MLibDoc.Export(ProjectPath, VGCore.cdrFilter.cdrPLT, VGCore.cdrExportRange.cdrSelection, opt) Dim Ef As ExportFilter = MLibDoc.ExportEx(ProjectPath, VGCore.cdrFilter.cdrPLT, VGCore.cdrExportRange.cdrSelection, opt) Ef.Finish() RsNode.CdrPath = ProjectPath.Replace(ServerFilePath, "") Case Else MLibDoc.Close() G_LibDoc.Close() RsNode.Status = RedisSendNode.StatusType.UnknownFail RsNode.Msg = "位置操作!!" RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) Return False End Select InpotMessage1($"16、保存图像成文件完成") G_LibDoc.Close() MLibDoc.Close() RsNode.Status = RedisSendNode.StatusType.Success RsNode.Msg = "Ok" InpotMessage1($"17、关闭素材库和目标文件") RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) InpotMessage1($"18、向Redis写入生成成功信息") Return True Catch ex As Exception APP.EventsEnabled = True APP.Optimization = False APP.Refresh() Select Case RsNode.Status Case RedisSendNode.StatusType.MaterialPositionNotExist RsNode.Msg = "素材位置不存在!!" Case RedisSendNode.StatusType.MaterialNotExist RsNode.Msg = "素材不存在!!" Case RedisSendNode.StatusType.BuildImageFail RsNode.Msg = "生成图像失败!!" Case RedisSendNode.StatusType.SaveFileFail RsNode.Msg = "保存文件失败!!" End Select RedisPublishMessage1(RsNode.PictureNum, JsonConvert.SerializeObject(RMNode)) If Not IsNothing(MLibDoc) Then MLibDoc.Close() End If If Not IsNothing(G_LibDoc) Then G_LibDoc.Close() End If gLogNode = New LogNode($"{RsNode.Msg}{vbCrLf}{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End Try End Function ''' ''' 计算缩放因子 ''' ''' 图像原始宽度 ''' 图像原始高度 ''' 槽位宽度 ''' 槽位高度 ''' 0=填满 1=完整 2=拉伸 ''' （scaleX, scaleY） Public Function GetScale(imgW As Double, imgH As Double, slotW As Double, slotH As Double, Optional mode As Integer = 1) As (Double, Double) Dim sx As Double = slotW / imgW Dim sy As Double = slotH / imgH ' Return mode switch '{ ' 0 => (Math.Max(sx, sy), Math.Max(sx, sy)), // 填满（保持比例） ' 1 => (Math.Min(sx, sy), Math.Min(sx, sy)), // 完整（保持比例） ' 2 => (sx, sy), // 强制拉伸 ' _ => (sx, sy) '}; Select Case mode Case 0 Return (Math.Max(sx, sy), Math.Max(sx, sy)) Case 1 Return (Math.Min(sx, sy), Math.Min(sx, sy)) Case 2 Return (sx, sy) Case Else Return (sx, sy) End Select End Function '創建字體圖像 Public Function CreateTextImage(nlayer As Layer, ShapeNumber As String, remark As String()) As Shape Dim chp As Shape Dim txtsize As Single If Not txtsize.TryParse(remark(1), txtsize) Then Return Nothing End If Try chp = nlayer.CreateArtisticText(0, 0, ShapeNumber, cdrTextLanguage.cdrLanguageNone, cdrTextCharSet.cdrCharSetDefault, remark(0), txtsize, cdrFontStyle.cdrNormalFontStyle) 'chp = nlayer.CreateArtisticText(0, 0, ShapeNumber, cdrTextLanguage.cdrLanguageNone, cdrTextCharSet.cdrCharSetDefault, remark(0), txtsize, cdrFontStyle.cdrNormalFontStyle) 'Dim chpcolor As New VGCore.Color Dim chpcolor As Color = New Color chpcolor.RGBAssign(255, 255, 255) chp.Fill.ApplyUniformFill(chpcolor) Return chp Catch ex As Exception Return Nothing End Try End Function '創建字體圖像 Public Function CreateTextImage2(nlayer As Layer, ShapeNumber As String, remark As String()) As Shape Dim chp As Shape Dim txtsize As Single If Not txtsize.TryParse(remark(1), txtsize) Then Return Nothing End If Try chp = nlayer.CreateArtisticText(0, 0, ShapeNumber, cdrTextLanguage.cdrLanguageNone, cdrTextCharSet.cdrCharSetDefault, remark(0), txtsize, cdrFontStyle.cdrNormalFontStyle) 'chp = nlayer.CreateArtisticText(0, 0, ShapeNumber, cdrTextLanguage.cdrLanguageNone, cdrTextCharSet.cdrCharSetDefault, remark(0), txtsize, cdrFontStyle.cdrNormalFontStyle) 'Dim chpcolor As New VGCore.Color Dim chpcolor As Color = New Color chpcolor.RGBAssign(0, 0, 0) chp.Fill.ApplyUniformFill(chpcolor) Return chp Catch ex As Exception Return Nothing End Try End Function Public Function CreateTextImage1(nlayer As Layer, ShapeNumber As String, LocationNode As LocationList) As Shape Dim chp As Shape Dim txtsize As Single If Not txtsize.TryParse(LocationNode.ShapeFontSize, txtsize) Then Return Nothing End If Try chp = nlayer.CreateArtisticText(0, 0, ShapeNumber, cdrTextLanguage.cdrLanguageNone, cdrTextCharSet.cdrCharSetDefault, LocationNode.ShapeFont, txtsize, cdrFontStyle.cdrNormalFontStyle) 'chp = nlayer.CreateArtisticText(0, 0, ShapeNumber, cdrTextLanguage.cdrLanguageNone, cdrTextCharSet.cdrCharSetDefault, remark(0), txtsize, cdrFontStyle.cdrNormalFontStyle) 'Dim chpcolor As New VGCore.Color Dim chpcolor As Color = New Color Dim colorint As (Integer, Integer, Integer) = HexToRgb(LocationNode.ShapeColor) chpcolor.RGBAssign(colorint.Item1, colorint.Item2, colorint.Item3) chp.Fill.ApplyUniformFill(chpcolor) chp.ConvertToCurves() Return chp Catch ex As Exception Return Nothing End Try End Function Public Sub shapeCopy(shp As Shape) Try shp.Copy() Catch ex As Exception ''Console.WriteLine($"图像[{shp.Name}]复制失败！") shapeCopy(shp) End Try End Sub '处理节点信息 'Public Function HandleNodeInformation(node As RedisInfoNode) As Boolean ' Dim gLogNode As LogNode ' Dim ProjectPath As String ' Dim MaterialPath As String = M_MaterialPath & node.MaterialLibraryName ' Dim RsNode As New RedisSendNode ' RsNode.User = node.User ' RsNode.ProjectName = node.ProjectName ' RsNode.ProjectId = node.ProjectId ' RsNode.PictureNum = node.PictureNum ' Dim oldTime As DateTime = Now ' '判断素材库是否存在 ' If Not File.Exists(MaterialPath) Then ' 'MsgBox("素材库不存在") ' RsNode.Status = RedisSendNode.StatusType.MaterialLibraryNotExist ' RsNode.Msg = "素材库不存在!" ' RedisPublishMessage(JsonConvert.SerializeObject(RsNode)) ' gLogNode = New LogNode("素材库不存在", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) ' gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' Return False ' End If ' ProjectPath = $"{M_TplPath}{node.ProjectName}\{Now:yyyyMMdd}" ' '判断项目文件夹是否存在 ' If Not Directory.Exists(ProjectPath) Then ' 'MsgBox("项目文件夹不存在") ' '创建文件夹 ' Directory.CreateDirectory(ProjectPath) ' End If ' '''Console.WriteLine($"到达节点1耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' ' Dim srcDoc As Document '素材文件 ' Dim NewDoc As Document '成平文件 ' Dim destLayer As Layer ' Dim shp As Shape = Nothing ' Dim dic As Dictionary(Of String, (Integer, Integer, Integer)) ' 'Dim app As New Application() '打开CorelDRAW并显示 ' '''Console.WriteLine($"到达节点2耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' Try ' 'Thread.Sleep(2000) ' 'APP.documents.CloseAll() ' '打开素材文件 ' '''Console.WriteLine($"到达节点11耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' 'Thread.Sleep(500) ' '创建新的成平文件 ' NewDoc = APP.CreateDocument() ' '''Console.WriteLine($"到达节点10耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' '查询素材数据并以键值对保存 ' dic = Gettbl_iconlibrary(node.MaterialLibraryName) ' If IsNothing(dic) OrElse dic.Count = 0 Then ' RsNode.Status = RedisSendNode.StatusType.GetMaterialFromDBFail ' RsNode.Msg = $"获取数据库素材失败！" ' RedisPublishMessage(JsonConvert.SerializeObject(RsNode)) ' Return False ' End If ' '''Console.WriteLine($"到达节点3耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' 'Thread.Sleep(500) ' destLayer = NewDoc.Pages(1).Layers(2) ' If queryThenIconTonewDoc(node.TemplateName, dic, G_LibDoc, destLayer, NewDoc.Pages(1)) Then ' '''Console.WriteLine($"到达节点4耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' For Each item In node.MaterialDic ' If queryThenIconTonewDoc(item.Value, dic, G_LibDoc, destLayer) Then ' '''Console.WriteLine($"到达节点5耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' If ReplaceTheCorrespondingImage(node.TemplateName, item.Key, item.Value, destLayer) Then ' NewDoc.Close() ' RsNode.Status = RedisSendNode.StatusType.MaterialPositionNotExist ' RsNode.Msg = $"未找到素材放置位置:'{item.Key}' ！" ' RedisPublishMessage(JsonConvert.SerializeObject(RsNode)) ' gLogNode = New LogNode($"未找到素材放置位置:'{item.Key}' ！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) ' gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' Return False ' End If ' Else ' NewDoc.Close() ' RsNode.Status = RedisSendNode.StatusType.MaterialNotExist ' RsNode.Msg = $"未找到素材:'{item.Value}' !" ' RedisPublishMessage(JsonConvert.SerializeObject(RsNode)) ' gLogNode = New LogNode($"未找到素材:'{item.Value}' ！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) ' gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' Return False ' End If ' Next ' '''Console.WriteLine($"到达节点6耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' Else ' NewDoc.Close() ' RsNode.Status = RedisSendNode.StatusType.TemplateNotExist ' RsNode.Msg = $"未找到模板'{node.TemplateName}'！！" ' RedisPublishMessage(JsonConvert.SerializeObject(RsNode)) ' gLogNode = New LogNode($"未找到模板'{node.TemplateName}'！！", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) ' gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' Return False ' End If ' SetIconName(node.TemplateName, destLayer) ' destLayer.SelectableShapes.All.Group().Name = node.TemplateName ' '''Console.WriteLine($"到达节点7耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' ProjectPath = $"{ProjectPath}\{node.TemplateName.Replace("Mode_", "")}_{Now:yyyyMMddHHmmss}.cdr" ' MaterialPath = ProjectPath.Replace(".cdr", ".jpg") ' '// 4) 导出 JPG ' Dim Ef As ExportFilter = NewDoc.ExportBitmap(MaterialPath, VGCore.cdrFilter.cdrPNG) ' Ef.Finish() ' NewDoc.SaveAs(ProjectPath) ' '''Console.WriteLine($"到达节点8耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' NewDoc.Close() ' RsNode.ImagePath = MaterialPath ' RsNode.CdrPath = ProjectPath ' RsNode.Status = RedisSendNode.StatusType.Success ' RsNode.Msg = "成功" ' RedisPublishMessage(JsonConvert.SerializeObject(RsNode)) ' gLogNode = New LogNode($"'{node.TemplateName.Replace("Mode_", "")}'图像文件生成完毕！！！", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) ' 'gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' '''Console.WriteLine($"到达节点9耗时：{(Now - oldTime).TotalMilliseconds}毫秒") ' Return True ' Catch ex As Exception ' If Not IsNothing(NewDoc) Then ' ' NewDoc.Close() ' End If ' gLogNode = New LogNode(ex.Message, RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) ' gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' Return False ' End Try ' Return True 'End Function '将hex转为rgb Public Function HexToRgb(hex As String) As (Integer, Integer, Integer) Try If String.IsNullOrEmpty(hex) Then Return (255, 255, 255) Dim r As Integer = Convert.ToInt32(hex.Substring(1, 2), 16) Dim g As Integer = Convert.ToInt32(hex.Substring(3, 2), 16) Dim b As Integer = Convert.ToInt32(hex.Substring(5, 2), 16) Return (r, g, b) Catch ex As Exception Return (255, 255, 255) End Try End Function Public Function Gettbl_iconlibrary(Version As String) As Dictionary(Of String, (Integer, Integer, Integer)) Dim dic As New Dictionary(Of String, (Integer, Integer, Integer)) Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Dim gLogNode As LogNode '将列表中的数据库语句组装成事务语句 Dim transStr As String = $"select * from `Cdr_library`.`tbl_iconlibrary` where `Version` ='{Version}';" '插入数据库 ' Using db As New DbExecutor(DbExecutor.DbTypeEnum.npgsql, LocalConnString) Dim dt As DataTable Try npgsqldb.Open() ' npgsqldb.ExecuteDataTable(transStr) dt = npgsqldb.ExecuteDataTable(transStr) '遍历行添加数据到dic For Each row As DataRow In dt.Rows If Not dic.ContainsKey(row("KeyName").ToString()) Then dic.Add(row("KeyName").ToString(), (row("PageNumber"), row("LayerNumber"), row("Shapenumber"))) Else dic.Item(row("KeyName").ToString()) = (row("PageNumber"), row("LayerNumber"), row("Shapenumber")) End If Next npgsqldb.Close() Catch ex As Exception If Not IsNothing(npgsqldb) Then npgsqldb.Close() End If 'AddLogMessage($"写入酒店日志异常！") gLogNode = New LogNode($"获取素材失败!{vbCrLf}{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return Nothing End Try 'gLogNode = New LogNode($"获取素材成功!{vbCrLf}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) ''gLogNode.SetLogColor(System.Drawing.Color.Red) 'G_Log.AddLogNode(gLogNode) Return dic End Function Public Sub SetIconToCentered(page As Page, nshape As Shape) Dim totalW As Double, totalH As Double totalW = page.SizeWidth totalH = page.SizeHeight Dim docCX As Double, docCY As Double docCX = totalW / 2 docCY = totalH / 2 nshape.SetPosition(docCX - nshape.SizeWidth / 2, totalH - nshape.SizeHeight / 2) 'nshape.CenterX = page.Width / 2 'nshape.CenterY = page.Height / 2 'nshape.Move(docCX, docCY) End Sub ''' ''' ''' ''' 被替换的图像 ''' 用来替换的图像名 ''' ''' '替换对应图像 Public Function ReplaceTheCorrespondingImage(TemplateName As String, iconnameA As String, iconnameB As String, destLayer As Layer) As Boolean Dim gLogNode As LogNode Dim shpA, shpB As Shape Dim x#, y#, w#, h# Dim dx As Double, dy As Double For Each shp As Shape In destLayer.Shapes '''Console.WriteLine(shp.Name) If shp.Name.Equals(TemplateName.Trim) Then For Each shp2 As Shape In shp.Shapes If shp2.Name.Equals(iconnameA.Trim) Then shpA = shp2 Exit For End If Next End If If shp.Name.Equals(iconnameB.Trim) Then shpB = shp End If Next If shpA Is Nothing Then Return False End If If shpB Is Nothing Then Return True End If x = shpA.CenterX - shpB.CenterX y = shpA.CenterY - shpB.CenterY dx = shpA.LeftX dy = shpA.TopY '''Console.WriteLine(shpA.Name) shpB.Move(x, y) shpA.Delete() End Function '设置图像名称 Public Function SetIconName(iconname As String, destLayer As Layer) As Boolean For Each shp As Shape In destLayer.Shapes If shp.Name.Equals(iconname.Trim) Then If shp.Type = cdrShapeType.cdrGroupShape Then shp.Ungroup() End If End If Next End Function ''' ''' 查找图像并拷贝到目标图层 中 ''' ''' ''' ''' ''' Public Function queryThenIconTonewDoc(iconname As String, dic As Dictionary(Of String, (Integer, Integer, Integer)), srcDoc As Document, destLayer As Layer, Optional fpage As Page = Nothing) As Boolean If String.IsNullOrEmpty(iconname) Then Return True Dim val As (Integer, Integer, Integer) Dim nshape As Shape If dic.ContainsKey(iconname.Trim) Then val = dic(iconname.Trim) Else Return False End If Dim page As Page = srcDoc.Pages(val.Item1) Dim layer As Layer = page.Layers(val.Item2) Dim shape As Shape = layer.Shapes(val.Item3) ' srcDoc.Pages(val.Item1).Layers(val.Item2).Shapes(val.Item3).Copy() 'nshape.Copy() shape.Copy() nshape = destLayer.Paste() If Not IsNothing(fpage) Then SetIconToCentered(fpage, nshape) End If Return True '遍历素材文件内的所有图层 'For Each nPage As Page In srcDoc.Pages ' '''Console.WriteLine(nPage.Name) ' '遍历图层内的所有图像 ' For Each Layer As Layer In nPage.Layers ' '''Console.WriteLine(Layer.Name) ' For Each Shape As Shape In Layer.Shapes ' '''Console.WriteLine(Shape.Name) ' '判断模板图像是否存在 ' If Shape.Name.Equals(iconname.Trim) Then ' Shape.Copy() ' nshape = destLayer.Paste() ' If Not IsNothing(fpage) Then ' SetIconToCentered(fpage, nshape) ' End If ' Return True ' End If ' Next ' Next 'Next 'Return False End Function '获取系统缓存参数 Public Sub GetSeting() '刷新系统缓存 My.Settings.Reload() '获取系统缓存参数 'ComboBox1.Text = My.Settings.SerialPortName 'ComboBox2.Text = My.Settings.BaudRate If My.Settings.THigh = 0 OrElse My.Settings.TWide = 0 Then Else Me.Height = My.Settings.THigh Me.Width = My.Settings.TWide End If G_Subscribe = My.Settings.G_Subscribe G_Publish = My.Settings.G_Publish ToolStripTextBox2.Text = G_Subscribe ToolStripTextBox1.Text = G_Publish 'Dim dic As Dictionary(Of Integer, (String, String, String)) 'dic = JsonConvert.DeserializeObject(Of Dictionary(Of Integer, (String, String, String)))(My.Settings.GTable) 'If IsNothing(dic) OrElse dic.Count = 0 Then Return 'JsonConvert.SerializeObject(m_Applicationconfig) End Sub '保存系统缓存参数 Public Sub SaveSeting() '刷新系统缓存 My.Settings.Reload() '获取系统缓存参数 'My.Settings.SerialPortName = ComboBox1.Text 'My.Settings.BaudRate = ComboBox2.Text My.Settings.THigh = Me.Height My.Settings.TWide = Me.Width My.Settings.G_Subscribe = G_Subscribe My.Settings.G_Publish = G_Publish Dim dic As New Dictionary(Of Integer, (String, String, String)) 'My.Settings.GTable = JsonConvert.SerializeObject(dic) My.Settings.Save() End Sub Public Sub initRedisPublisher() If Not IsNothing(G_Redislish) AndAlso G_Redislish.IsConnected Then G_Redislish.CloseConnection() End If ' 替换为你的 Redis 连接字符串 'Dim connectionString = "127.0.0.1:6379" Try G_Redislish = New RedisSubscriber(M_Redisip, M_Redisport, M_Redispassword) Catch ex As Exception MsgBox($"redis发布初始化失败:{ex.Message}") End Try End Sub Public Sub RedisPublishMessage(message As String) If String.IsNullOrEmpty(G_Publish) Then MsgBox("未设置发布频道") Return End If If String.IsNullOrEmpty(message) Then MsgBox("未输入发布内容") Return End If If G_Redislish.IsConnected Then Dim gLogNode As LogNode Try G_Redislish.PublishMessage(G_Publish, message) gLogNode = New LogNode($"Redis:{G_Publish}: {message}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) Catch ex As Exception 'MsgBox($"redis发布失败:{ex.Message}") gLogNode = New LogNode(ex.Message, RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) End Try Else MsgBox("redis未连接") End If End Sub Public Sub RedisPublishMessage1(key As String, message As String) If String.IsNullOrEmpty(G_Publish) Then MsgBox("未设置发布频道") Return End If If String.IsNullOrEmpty(message) Then MsgBox("未输入发布内容") Return End If Dim gLogNode As LogNode Try Dim config As ConfigurationOptions = New ConfigurationOptions() config.EndPoints.Add(M_Redisip, M_Redisport) ' 设置Redis服务器地址和端口 config.Password = M_Redispassword ' 设置Redis密码 config.AbortOnConnectFail = False ' 连接失败时不中止 Dim conn = ConnectionMultiplexer.Connect(config) Dim db = conn.GetDatabase(0) db.StringSet(key, message) gLogNode = New LogNode($"Redis:{G_Publish}: {message}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) Catch ex As Exception 'MsgBox($"redis发布失败:{ex.Message}") gLogNode = New LogNode(ex.Message, RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) End Try End Sub Private Sub ToolStripButton4_Click(sender As Object, e As EventArgs) Handles ToolStripButton4.Click If String.IsNullOrEmpty(ToolStripTextBox2.Text) Then MsgBox("请输入订阅频道") Return Else G_OldSubscribe = G_Subscribe G_Subscribe = ToolStripTextBox2.Text.Trim End If If String.IsNullOrEmpty(ToolStripTextBox1.Text) Then MsgBox("请输入发布频道") Return Else G_Publish = ToolStripTextBox1.Text.Trim End If initRedisSubscriber(G_Subscribe, G_OldSubscribe) initRedisPublisher() End Sub Public Sub initRedisSubscriber(Subscribe As String, OldSubscribe As String) If String.IsNullOrEmpty(Subscribe) Then MsgBox("未设置订阅频道") Return End If If Not IsNothing(G_RedisSub) AndAlso G_RedisSub.IsConnected Then ' 取消订阅并关闭连接 G_RedisSub.UnsubscribeFromChannel(OldSubscribe) G_RedisSub.CloseConnection() End If ' 替换为你的 Redis 连接字符串 ' Dim connectionString = "127.0.0.1:10079,password=" Try G_RedisSub = New RedisSubscriber(M_Redisip, M_Redisport, M_Redispassword) ' 定义消息处理程序 Dim messageHandler As Action(Of RedisChannel, RedisValue) = Sub(channel, message) '将消息输出添加到队列 Dim gLogNode As LogNode Dim g_CallInfoNode As RedisMsgNode Try g_CallInfoNode = JsonConvert.DeserializeObject(Of RedisMsgNode)(message) Catch ex As Exception 'MsgBox($"消息解析失败:{ex.Message}") gLogNode = New LogNode(ex.Message, RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End Try If IsNothing(g_CallInfoNode) Then gLogNode = New LogNode($"【序列化失败】Redis:{channel}: {message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If gLogNode = New LogNode($"Redis:{channel}: {message}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) G_Log.AddLogNode(gLogNode) M_RedisQueue.Enqueue(g_CallInfoNode) 'RuningLog.OutputLogsToTheControl(RichTextBox1, New RuningLogConfig($"Redis接收到来自 {channel} 的消息: {message}", System.Drawing.Color.DarkOrange, 12), 1) ''''Console.WriteLine($"接收到来自 {channel} 的消息: {message}") End Sub ' 订阅频道 G_RedisSub.SubscribeToChannel(Subscribe, messageHandler) Catch ex As Exception MsgBox($"订阅失败:{ex.Message}") End Try '' 发布消息示例 ''''Console.WriteLine("发布测试消息...") 'G_RedisSub.PublishMessage("testChannel", "Hello from publisher!") '' 保持程序运行以接收更多消息 ''''Console.WriteLine("按任意键退出...") '''Console.ReadKey() End Sub Private Sub RichTextBox1_TextChanged(sender As Object, e As EventArgs) Handles RichTextBox1.TextChanged If RichTextBox1.Lines.Length > 2147000000 Then RichTextBox1.Clear() End If End Sub ' 用于存储文件名和对应id的字典 Private M_FileIdDict As New Dictionary(Of String, Integer) Private Sub ToolStripComboBox1_DropDown(sender As Object, e As EventArgs) Handles ToolStripComboBox1.DropDown ' 清空下拉列表和字典 ToolStripComboBox1.Items.Clear() M_FileIdDict.Clear() Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Dim gLogNode As LogNode ' 从tbl_cdr_file表查询图库文件名和文件对应id Dim transStr As String = "select id, filename from `cdr_library`.`tbl_cdr_file`;" Dim dt As DataTable Try npgsqldb.Open() dt = npgsqldb.ExecuteDataTable(transStr) ' 将查询结果填充到ToolStripComboBox1下拉框中 For Each row As DataRow In dt.Rows Dim id As Integer = row("id") Dim filename As String = row("filename") ' 将id和filename存储到字典中 M_FileIdDict.Add(filename, id) ' 下拉框中只显示文件名 ToolStripComboBox1.Items.Add(filename) Next npgsqldb.Close() Catch ex As Exception If Not IsNothing(npgsqldb) Then npgsqldb.Close() End If gLogNode = New LogNode($"查询图库文件失败!{vbCrLf}{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) End Try End Sub Private Sub ToolStripButton3_Click(sender As Object, e As EventArgs) Handles ToolStripButton3.Click RichTextBox1.Clear() Dim dic As New Dictionary(Of String, String) 'dic.Add("a", "1") ''将dic 序列化成字符串 'Dim json As String = JsonConvert.SerializeObject(dic) ''控制台输出(json) ''''Console.WriteLine(json) End Sub Private Sub CorelDRAW_FormClosed(sender As Object, e As FormClosedEventArgs) Handles MyBase.FormClosed SaveSeting() RedisClose() If Not IsNothing（M_EventThread） AndAlso M_EventThread.IsAlive Then M_EventThread.Abort() End If If Not IsNothing（G_Log） Then G_Log.CloseThread() End If End Sub '关闭redis Public Sub RedisClose() If Not IsNothing(G_RedisSub) AndAlso G_RedisSub.IsConnected Then G_RedisSub.UnsubscribeFromChannel(G_Subscribe) G_RedisSub.CloseConnection() End If If Not IsNothing(G_Redislish) AndAlso G_Redislish.IsConnected Then G_Redislish.CloseConnection() End If End Sub Private Sub ToolStripButton1_Click_1(sender As Object, e As EventArgs) Handles ToolStripButton1.Click '打开文件选择器 选择cDR后缀的文件 Dim ServerFilePath As String = M_ServerPath ' "R:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic" ' "D:\IIS ROOT\BLWLog\Web\wwwroot\PanelSelectionPic" ' Dim OpenFileDialog1 As New OpenFileDialog() OpenFileDialog1.Filter = "CorelDRAW Files (*.cdr)|*.cdr" Dim srcDoc As Document '素材文件 Dim MaterialPath As String Dim strbuf() As String Dim li As New List(Of String) Dim Version As String Dim Location As String Dim icontype As Integer Dim pint, lint, Sint, Locationint, nsint, typeid As Integer Dim gLogNode As LogNode Dim ProjectPath As String Dim SafeFileName As String Dim errorMessage As String Dim xvbnode As Shape If OpenFileDialog1.ShowDialog() = DialogResult.OK Then ' 上传前检查文件是否符合规范 If Not CheckLibraryFile(OpenFileDialog1.FileName, errorMessage) Then gLogNode = New LogNode($"图库文件检测失败：{errorMessage}{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) MessageBox.Show(errorMessage, "文件检测失败", MessageBoxButtons.OK, MessageBoxIcon.Error) Return End If Dim fid As Integer = AddFileToSQL(OpenFileDialog1.SafeFileName) If fid = -1 Then gLogNode = New LogNode($"获取FId失败，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If '创建以文件名去除后缀 命名的文件夹 SafeFileName = OpenFileDialog1.SafeFileName.Substring(0, OpenFileDialog1.SafeFileName.LastIndexOf(".")) ProjectPath = ServerFilePath & "\" & SafeFileName If Not Directory.Exists(ProjectPath) Then Directory.CreateDirectory(ProjectPath) End If If Not Directory.Exists(ProjectPath & "\iconlibrary\") Then Directory.CreateDirectory(ProjectPath & "\iconlibrary\") End If MaterialPath = OpenFileDialog1.FileName srcDoc = APP.OpenDocument(MaterialPath, False) 'Version=文件名称 Version = srcDoc.Name '遍历素材文件内的所有图层 Dim nshape As Shape pint = 0 lint = 0 Sint = 0 nsint = 0 Dim xm, hm, wm As Double Dim modeindex As Integer = 0 '遍历所有页 For Each nPage As Page In srcDoc.Pages '''Console.WriteLine("PAGE:" & nPage.Name) pint = pint + 1 lint = 0 '遍历图层内的所有图层 For Each Layer As Layer In nPage.Layers '''Console.WriteLine("Layer:" & Layer.Name) lint = lint + 1 Sint = 0 '遍历图层内的所有形状 For Each Shape As Shape In Layer.Shapes Sint = Sint + 1 If String.IsNullOrEmpty(Shape.Name) Then Continue For '''Console.WriteLine("Shape:" & Shape.Name) strbuf = Shape.Name.Split("_") If strbuf.Length < 2 Then Continue For Location = $"{pint}_{lint}_{Sint}" Select Case strbuf(0).ToLower Case "Mode".ToLower For i = Shape.Shapes.Count To 1 Step -1 xvbnode = Shape.Shapes.Item(i) '将子节点中名称带有Effect _ 的节点删除 If xvbnode.Name.Contains("Effect") Then xvbnode.Visible = False End If Next Dim modepath As String = $"{ProjectPath}\Mode\" If Not Directory.Exists(modepath) Then Directory.CreateDirectory(modepath) End If Dim Direction As String Direction = strbuf(1).Replace("连体", "").Trim If Not Double.TryParse(Direction, xm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If If Not Double.TryParse(strbuf(4), wm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If If Not Double.TryParse(strbuf(5), hm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If If strbuf(2).Equals("横向") OrElse strbuf(2).Equals("竖向") Then Direction = strbuf(2).Trim Else gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If modepath = $"{SafeFileName}\Mode\{Shape.Name}.png" nsint = AddModeToSql(Shape.Name, fid, Location, Direction, xm, wm, hm, strbuf(3), modepath) modepath = $"{ProjectPath}\Mode\{Shape.Name}.png" If nsint = -1 Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If Dim schpcolor As New Color schpcolor.RGBAssign(255, 255, 255) schpcolor = SetImageStyle1(Shape, True, schpcolor) Shape.Selected = True Dim Ef As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() SetImageStyle1(Shape, False, schpcolor) Shape.Selected = False If modeindex = 0 Then modeindex = modeindex + 1 '更新 tbl_cdr_file表 Shape.Selected = True modepath = $"{ProjectPath}\Mode\ShapeName.png" Dim NEf As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) NEf.Finish() Shape.Selected = False modepath = $"{SafeFileName}\Mode\ShapeName.png" Dim sql As String = $"UPDATE `Cdr_library`.`tbl_cdr_file` SET `PreviewPath` = '{modepath.Replace("\", "\\")}' WHERE `ID` = {fid};{vbCrLf}" li.Add(sql) End If Locationint = 0 For Each nshape In Shape.Shapes Locationint = Locationint + 1 If nshape.Name.Contains("Trench_") Then Dim cstrbuf As String() = nshape.Name.Split("_") If Not Double.TryParse(cstrbuf(2), wm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If If Not Double.TryParse(cstrbuf(3), hm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If li.Add($"INSERT INTO `Cdr_library`.`tbl_trench` (`MID`,`TrenchName`,`SizeH`,`SizeW`,`IndexNum`)VALUES({nsint},'{nshape.Name.Trim}',{hm},{wm},{Locationint});{vbCrLf}") ElseIf nshape.Name.Contains("Logo_") Then Dim cstrbuf As String() = nshape.Name.Split("_") If Not Double.TryParse(cstrbuf(3), wm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If If Not Double.TryParse(cstrbuf(4), hm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If '判断 第3个元素 是否为R或L If cstrbuf(2).Trim.ToLower = "l" Then li.Add($"UPDATE `Cdr_library`.`tbl_model` SET `LOGO_L` = '{Locationint}',`LOGO_L_W` = {wm},`LOGO_L_H` = {hm} WHERE `ID` = {nsint};{vbCrLf}") ElseIf cstrbuf(2).Trim.ToLower = "r" Then '更新 tbl_model 表 li.Add($"UPDATE `Cdr_library`.`tbl_model` SET `LOGO_R` = '{Locationint}',`LOGO_R_W` = {wm},`LOGO_R_H` = {hm} WHERE `ID` = {nsint};{vbCrLf}") End If End If Next Case "Mono".ToLower Dim modepath As String = $"{ProjectPath}\Mono" If Not Directory.Exists(modepath) Then Directory.CreateDirectory(modepath) End If modepath = $"{SafeFileName}\Mono\{Shape.Name}.png" nsint = AddMonoToSQL(Shape.Name, fid, Location, modepath) modepath = $"{ProjectPath}\Mono\{Shape.Name}.png" If nsint = -1 Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If Dim schpcolor As New Color schpcolor.RGBAssign(255, 255, 255) schpcolor = SetImageStyle(Shape, True, schpcolor) Shape.Selected = True Dim Ef As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() SetImageStyle(Shape, False, schpcolor) Shape.Selected = False Dim dic As New Dictionary(Of String, Integer) Locationint = 0 Dim Keygroup As Integer = 1 Dim KeygroupID As Integer = 0 For Each nshape In Shape.Shapes Locationint = Locationint + 1 If nshape.Name.Contains("location_") Then Dim cstrbuf As String() = nshape.Name.Split("_") If dic.ContainsKey(cstrbuf(2).Trim) Then KeygroupID = dic(cstrbuf(2).Trim) Else Keygroup = Keygroup + 1 KeygroupID = Keygroup dic.Add(cstrbuf(2).Trim, Keygroup) End If If Not Double.TryParse(cstrbuf(3), wm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If If Not Double.TryParse(cstrbuf(4), hm) Then gLogNode = New LogNode($"图像{Shape.Name}异常，上传素材失败!{vbCrLf}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return End If typeid = GetIconType(cstrbuf(1).Trim) If typeid = 3 Then If cstrbuf.Length > 5 Then li.Add($"INSERT INTO `Cdr_library`.`tbl_location` (`PID`,`LocationName`,`Type`,`SizeH`,`SizeW`,`IndexNum`,`lineNumber`,`KeyGroup`)VALUES({nsint},'{nshape.Name.Trim}','{typeid}',{hm},{wm},{Locationint},'{cstrbuf(5).Trim}',{KeygroupID});{vbCrLf}") Else li.Add($"INSERT INTO `Cdr_library`.`tbl_location` (`PID`,`LocationName`,`Type`,`SizeH`,`SizeW`,`IndexNum`,`KeyGroup`)VALUES({nsint},'{nshape.Name.Trim}','{typeid}',{hm},{wm},{Locationint},{KeygroupID});{vbCrLf}") End If Else li.Add($"INSERT INTO `Cdr_library`.`tbl_location` (`PID`,`LocationName`,`Type`,`SizeH`,`SizeW`,`IndexNum`,`KeyGroup`)VALUES({nsint},'{nshape.Name.Trim}','{typeid}',{hm},{wm},{Locationint},{KeygroupID});{vbCrLf}") End If End If Next Case "Icon".ToLower Dim chpcolor As New Color Dim ShapeName As String = Shape.Name.Trim ShapeName = ShapeName.Replace("%", "").Replace("/", "").Replace(":", "").Replace("*", "").Replace("?", "").Replace("""", "").Replace("<", "").Replace(">", "").Replace("|", "").Replace("+", "") chpcolor.RGBAssign(0, 0, 0) Shape.Fill.ApplyUniformFill(chpcolor) Dim modepath As String = $"{ProjectPath}\iconlibrary\{ShapeName}.png" Console.WriteLine(modepath) Shape.Selected = True Dim Ef As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() Dim KeyNamebuf As String() = Shape.Name.Trim.Split("_") chpcolor.RGBAssign(255, 255, 255) Shape.Fill.ApplyUniformFill(chpcolor) Shape.Selected = False modepath = $"{SafeFileName}\iconlibrary\{ShapeName}.png" modepath = modepath.Replace("\", "\\") '文件名不能包含以下字符：‌反斜杠(\)、正斜杠(/)、冒号(:)、星号(*)、问号(?)、双引号(")、小于号(<)、大于号(>)、竖线(|)‌，以及‌点(.)或百分号(%)‌作为名称。‌ icontype = 1 li.Add($"INSERT INTO `Cdr_library`.`tbl_iconlibrary` (`IconType`,`KeyName`,`FID`,`Shapenumber`,`PreviewPath`,`NameCN`,`NameEn`)VALUES({icontype},'{Shape.Name.Trim}',{fid},'{Location}','{modepath}','{KeyNamebuf(1) }','{KeyNamebuf(2) }');{vbCrLf}") Case "Txt".ToLower Dim chpcolor As New Color chpcolor.RGBAssign(0, 0, 0) Shape.Fill.ApplyUniformFill(chpcolor) Dim modepath As String = $"{ProjectPath}\iconlibrary\{Shape.Name}.png" Shape.Selected = True Dim Ef As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() chpcolor.RGBAssign(255, 255, 255) Shape.Fill.ApplyUniformFill(chpcolor) Shape.Selected = False modepath = $"{SafeFileName}\iconlibrary\{Shape.Name}.png" modepath = modepath.Replace("\", "\\") icontype = 2 li.Add($"INSERT INTO `Cdr_library`.`tbl_iconlibrary` (`IconType`,`KeyName`,`FID`,`Shapenumber`,`PreviewPath`)VALUES({icontype},'{Shape.Name.Trim}',{fid},'{Location}','{modepath}');{vbCrLf}") Case "TxtEn".ToLower Dim chpcolor As New Color chpcolor.RGBAssign(0, 0, 0) Shape.Fill.ApplyUniformFill(chpcolor) Dim modepath As String = $"{ProjectPath}\iconlibrary\{Shape.Name}.png" Shape.Selected = True Dim Ef As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() chpcolor.RGBAssign(255, 255, 255) Shape.Fill.ApplyUniformFill(chpcolor) Shape.Selected = False modepath = $"{SafeFileName}\iconlibrary\{Shape.Name}.png" modepath = modepath.Replace("\", "\\") icontype = 3 li.Add($"INSERT INTO `Cdr_library`.`tbl_iconlibrary` (`IconType`,`KeyName`,`FID`,`Shapenumber`,`PreviewPath`)VALUES({icontype},'{Shape.Name.Trim}',{fid},'{Location}','{modepath}');{vbCrLf}") 'Case "IconB".ToLower ' icontype = 5 ' li.Add($"INSERT INTO `Cdr_library`.`tbl_iconlibrary` (`IconType`,`KeyName`,`Version`,`Shapenumber`)VALUES({icontype},'{Shape.Name.Trim}','{Version.Trim}','{Location}');{vbCrLf}") Case "Logo".ToLower Dim chpcolor As New Color chpcolor.RGBAssign(0, 0, 0) Shape.Fill.ApplyUniformFill(chpcolor) Dim modepath As String = $"{ProjectPath}\iconlibrary\{Shape.Name}.png" Shape.Selected = True Dim Ef As ExportFilter = srcDoc.ExportBitmap(modepath, VGCore.cdrFilter.cdrPNG, VGCore.cdrExportRange.cdrSelection, VGCore.cdrImageType.cdrRGBColorImage) Ef.Finish() chpcolor.RGBAssign(255, 255, 255) Shape.Fill.ApplyUniformFill(chpcolor) Shape.Selected = False modepath = $"{SafeFileName}\iconlibrary\{Shape.Name}.png" modepath = modepath.Replace("\", "\\") icontype = 4 li.Add($"INSERT INTO `Cdr_library`.`tbl_iconlibrary` (`IconType`,`KeyName`,`FID`,`Shapenumber`,`PreviewPath`)VALUES({icontype},'{Shape.Name.Trim}',{fid},'{Location}','{modepath}');{vbCrLf}") Case Else Continue For End Select If li.Count >= 500 Then If AddLogMessageToSQL(li) Then li.Clear() Else srcDoc.Close() Return End If End If Next Next Next If AddLogMessageToSQL(li) Then li.Clear() Else srcDoc.Close() Return End If srcDoc.Close() End If End Sub Private Function SetImageStyle1(Shape As Shape, isTransparent As Boolean, Transparentcolor As Color) '设置图像背景色为透明 Dim Transparent As Integer Dim chpcolor As New Color Dim result As New Color Dim r, g, b, a As Integer If isTransparent Then Transparent = 100 chpcolor.RGBAssign(102, 102, 102) Else Transparent = 0 chpcolor.RGBAssign(255, 255, 255) End If For i As Integer = 1 To Shape.Shapes.Count If Shape.Shapes(i).Name.ToLower.Contains("IconB".ToLower) Then Select Case Shape.Shapes(i).Fill.UniformColor.Type Case cdrColorType.cdrColorCMYK Dim C As Double, M As Double, Y As Double, K As Double C = Shape.Shapes(i).Fill.UniformColor.CMYKCyan M = Shape.Shapes(i).Fill.UniformColor.CMYKMagenta Y = Shape.Shapes(i).Fill.UniformColor.CMYKYellow K = Shape.Shapes(i).Fill.UniformColor.CMYKBlack result.CMYKAssign(C, M, Y, K) Case cdrColorType.cdrColorRGB r = Shape.Shapes(i).Fill.UniformColor.RGBRed g = Shape.Shapes(i).Fill.UniformColor.RGBGreen b = Shape.Shapes(i).Fill.UniformColor.RGBBlue result.RGBAssign(r, g, b) Case Else result.RGBAssign(255, 255, 255) End Select 'Shape.Shapes(i).Transparency.ApplyUniformTransparency(Transparent) Shape.Shapes(i).Fill.ApplyUniformFill(Transparentcolor) Else Shape.Shapes(i).Fill.ApplyUniformFill(chpcolor) End If Next Return result End Function '设置图片样式 Private Function SetImageStyle(Shape As Shape, isTransparent As Boolean, Transparentcolor As Color) '设置图像背景色为透明 Dim Transparent As Integer Dim chpcolor As New Color Dim result As New Color Dim r, g, b, a As Integer If isTransparent Then Transparent = 100 chpcolor.RGBAssign(102, 102, 102) Else Transparent = 0 chpcolor.RGBAssign(255, 255, 255) End If For i As Integer = 1 To Shape.Shapes.Count If i = Shape.Shapes.Count Then Select Case Shape.Shapes(i).Fill.UniformColor.Type Case cdrColorType.cdrColorCMYK Dim C As Double, M As Double, Y As Double, K As Double C = Shape.Shapes(i).Fill.UniformColor.CMYKCyan M = Shape.Shapes(i).Fill.UniformColor.CMYKMagenta Y = Shape.Shapes(i).Fill.UniformColor.CMYKYellow K = Shape.Shapes(i).Fill.UniformColor.CMYKBlack result.CMYKAssign(C, M, Y, K) Case cdrColorType.cdrColorRGB r = Shape.Shapes(i).Fill.UniformColor.RGBRed g = Shape.Shapes(i).Fill.UniformColor.RGBGreen b = Shape.Shapes(i).Fill.UniformColor.RGBBlue result.RGBAssign(r, g, b) Case Else result.RGBAssign(255, 255, 255) End Select 'Shape.Shapes(i).Transparency.ApplyUniformTransparency(Transparent) Shape.Shapes(i).Fill.ApplyUniformFill(Transparentcolor) Else Shape.Shapes(i).Fill.ApplyUniformFill(chpcolor) End If Next Return result End Function '获取类型信息 Private Function GetIconType(Shapetype As String) As Integer Select Case Shapetype.ToLower Case "Icon".ToLower Return 1 Case "Txt".ToLower Return 2 Case "TxtEn".ToLower Return 3 'Case "IconB".ToLower ' Return 5 Case "Logo".ToLower Return 5 Case Else Return 0 End Select End Function Public Function AddModeToSql(modename As String, fid As Integer, Location As String, Direction As String, xm As Integer, wm As Integer, hm As Integer, Colorstr As String, PreviewPath As String) As Integer Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Dim transStr As String Dim transStr1 As String Dim dt As DataTable Dim result As Integer = -1 PreviewPath = PreviewPath.Replace("\", "\\") transStr = $"INSERT INTO `Cdr_library`.`tbl_model` (`FID`,`ModelName`,`Direction`,`SizeH`,`SizeW`,`Color`,`PanelCount`,`ShapeNumber`,`PreviewPath`)VALUES({fid},'{modename}','{Direction}',{hm},{wm},'{Colorstr}',{xm},'{Location}','{PreviewPath}');{vbCrLf}" transStr1 = $"select * From `Cdr_library`.`tbl_model` where `FID`={fid} and `ModelName`='{modename}'" Try npgsqldb.Open() npgsqldb.ExecuteNonQuery(transStr) dt = npgsqldb.ExecuteDataTable(transStr1) If dt.Rows.Count > 0 Then result = dt.Rows(0).Item("ID") End If npgsqldb.Close() Catch ex As Exception If Not IsNothing(npgsqldb) Then npgsqldb.Close() End If End Try Return result End Function Private Function AddMonoToSQL(Mononame As String, Fid As Integer, Location As String, PreviewPath As String) As Integer Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Dim strbuf As String() = Mononame.Split("_") Dim transStr As String Dim transStr1 As String Dim dt As DataTable Dim result As Integer = -1 Dim xm, hm, wm As Double PreviewPath = PreviewPath.Replace("\", "\\") If strbuf.Length > 3 Then If Not Double.TryParse(strbuf(2), wm) Then Return result End If If Not Double.TryParse(strbuf(3), hm) Then Return result End If transStr = $"INSERT INTO `Cdr_library`.`tbl_pattern` (`FID`,`PatternName`,`ShapeNumber`,`SizeW`,`SizeH`,`PreviewPath`)VALUES({Fid},'{Mononame}','{Location}',{wm},{hm},'{PreviewPath}');{vbCrLf}" Else Return result End If transStr1 = $"select * From `Cdr_library`.`tbl_pattern` where `FID`={Fid} and `PatternName`='{Mononame}'" Try npgsqldb.Open() npgsqldb.ExecuteNonQuery(transStr) dt = npgsqldb.ExecuteDataTable(transStr1) If dt.Rows.Count > 0 Then result = dt.Rows(0).Item("ID") End If npgsqldb.Close() Catch ex As Exception If Not IsNothing(npgsqldb) Then npgsqldb.Close() End If End Try Return result End Function '录入文件到数据表 Private Function AddFileToSQL(filenmae As String, Optional username As String = "TestUser", Optional Remark As String = "") As Integer Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Dim gLogNode As LogNode Dim strbuf As String() = filenmae.Split("_") Dim transStr As String Dim transStr1 As String Dim transStr2 As String Dim dt As DataTable Dim result As Integer = -1 If strbuf.Length > 3 Then transStr = $"INSERT INTO `Cdr_library`.`tbl_cdr_file` (`Company`,`Series`,`FileName`,`Version`,`Remark`,`User`,`UpdateTime`)VALUES('{strbuf(0)}','{strbuf(1)}','{filenmae}','{strbuf(3)}','{Remark}','{username}','{Now.ToString("yyyy-MM-dd HH:mm:ss") }');{vbCrLf}" ElseIf strbuf.Length > 4 Then transStr = $"INSERT INTO `Cdr_library`.`tbl_cdr_file` (`Company`,`Series`,`FileName`,`Version`,`Remark`,`User`,`UpdateTime`,`Remark`)VALUES('{strbuf(0)}','{strbuf(1)}','{filenmae}','{strbuf(3)}','{Remark}','{username}','{Now.ToString("yyyy-MM-dd HH:mm:ss") }','{strbuf(4)}');{vbCrLf}" Else transStr = $"INSERT INTO `Cdr_library`.`tbl_cdr_file` (`Company`,`Series`,`FileName`,`Version`,`Remark`,`User`,`UpdateTime`)VALUES('未知','未知','{filenmae}','未知','{Remark}','{username}','{Now.ToString("yyyy-MM-dd HH:mm:ss")}');{vbCrLf}" End If transStr1 = $"select * From `Cdr_library`.`tbl_cdr_file` where `FileName`='{filenmae}'" Try npgsqldb.Open() dt = npgsqldb.ExecuteDataTable(transStr1) If dt.Rows.Count > 0 Then Return -1 End If npgsqldb.ExecuteNonQuery(transStr) dt = npgsqldb.ExecuteDataTable(transStr1) If dt.Rows.Count > 0 Then result = dt.Rows(0).Item("ID") End If npgsqldb.Close() Catch ex As Exception If Not IsNothing(npgsqldb) Then npgsqldb.Close() End If End Try Return result End Function '添加一天数据如果数据超过500条则插入到数据库中 Private Function AddLogMessageToSQL(msglist As List(Of String)) As Boolean '最大条数 = 500 Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Dim gLogNode As LogNode '将列表中的数据库语句组装成事务语句 Dim transStr As String = String.Join("", msglist.ToArray) '插入数据库 ' Using db As New DbExecutor(DbExecutor.DbTypeEnum.npgsql, LocalConnString) Try npgsqldb.Open() npgsqldb.BeginTransaction() npgsqldb.ExecuteNonQuery(transStr) npgsqldb.CommitTransaction() msglist.Clear() npgsqldb.Close() Catch ex As Exception If Not IsNothing(npgsqldb) Then npgsqldb.RollbackTransaction() npgsqldb.Close() End If 'AddLogMessage($"写入酒店日志异常！") gLogNode = New LogNode($"上传素材失败!{vbCrLf}{ex.Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) Return False End Try gLogNode = New LogNode($"上传素材成功!{vbCrLf}", RuningLog.LogType.e_info, RuningLog.LogMode.e_fileandRichTextBox) 'gLogNode.SetLogColor(System.Drawing.Color.Red) G_Log.AddLogNode(gLogNode) ' End Using '清空列表 Return True End Function Public Isdisply As Boolean = False Private Sub ToolStripButton2_Click(sender As Object, e As EventArgs) Handles ToolStripButton2.Click Isdisply = Not Isdisply 'Dim srcDoc， destDoc1， destDoc2 As Document '素材文件 'Dim OpenFileDialog1 As New OpenFileDialog() 'OpenFileDialog1.Filter = "CorelDRAW Files (*.cdr)|*.cdr" 'Dim MaterialPath As String 'Dim oldTime As DateTime 'Dim shp, nshp As Shape 'If OpenFileDialog1.ShowDialog() = DialogResult.OK Then ' oldTime = Now ' MaterialPath = OpenFileDialog1.FileName ' srcDoc = APP.OpenDocument(MaterialPath, False) ' shp = srcDoc.Pages(1).Layers(2).Shapes(19) ' ''Console.WriteLine("打开库文件耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' destDoc1 = APP.OpenDocument(M_MaterialPath & "test1.cdr", False) ' destDoc1.Close() ' ''Console.WriteLine("打开关闭目标文件耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' destDoc1 = APP.OpenDocument(M_MaterialPath & "test1.cdr", False) ' ''Console.WriteLine("打开目标文件耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' '循环复制图像到目标文件 ' shp.Copy() ' For i = 1 To 10 ' destDoc1.Pages(1).Layers(2).Paste() ' Next ' ''Console.WriteLine("复制耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' destDoc1.Save() ' destDoc1.Close() ' ''Console.WriteLine("保存耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' destDoc1 = APP.CreateDocument() ' ''Console.WriteLine("创建新文件耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' For i = 1 To 10 ' destDoc1.Pages(1).Layers(2).Paste() ' Next ' ''Console.WriteLine("复制耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' Dim srcFile1 As String = M_MaterialPath & "test2.cdr" ' destDoc1.SaveAs(srcFile1) ' destDoc1.Close() ' ''Console.WriteLine("保存耗时：" & (Now - oldTime).TotalMilliseconds & "ms") ' srcDoc.Close() ' ''Console.WriteLine("关闭库耗时：" & (Now - oldTime).TotalMilliseconds & "ms") 'End If End Sub ''把剩余的数据也插入到数据库中 'Private Sub AddLogMessageToSQL(ByRef msglist As List(Of String), npgsqldb As DbExecutor) ' If msglist.Count = 0 Then Return ' Dim transStr As String = String.Join("", msglist.ToArray) ' '插入数据库 ' ' Using db As New DbExecutor(DbExecutor.DbTypeEnum.npgsql, LocalConnString) ' npgsqldb.Open() ' Try ' npgsqldb.BeginTransaction() ' npgsqldb.ExecuteNonQuery(transStr) ' npgsqldb.CommitTransaction() ' msglist.Clear() ' Catch ex As Exception ' npgsqldb.RollbackTransaction() ' AddLogMessage($"写入酒店日志异常！") ' gLogNode = New LogNode($"【序列化失败】Redis:{channel}: {Message}", RuningLog.LogType.e_Error, RuningLog.LogMode.e_fileandRichTextBox) ' gLogNode.SetLogColor(System.Drawing.Color.Red) ' G_Log.AddLogNode(gLogNode) ' End Try ' npgsqldb.Close() ' 'End Using 'End Sub Private Sub ToolStripButton1_Click(sender As Object, e As EventArgs) Dim srcDoc As Document Dim destDoc As Document Dim destDoc1 As Document Dim srcLayer As Layer Dim destLayer As Layer Dim shp, nshp As Shape Dim srcFile As String Dim destFile As String Dim srPaste As New ShapeRange Dim boxShape As Shape, sh As Shape Dim dx As Double, dy As Double Dim srcFile1 As String = "C:\Canvas\ms_2.cdr" destFile = "C:\Canvas\ms_1.cdr" srcFile = "C:\Canvas\Test_3.cdr" Dim app As New Application() app.Visible = False Thread.Sleep(2000) Dim nn As Integer = 0 Dim x#, y#, w#, h# 'Dim doc As Document = app.OpenDocument(tplPath, False) 'Dim doc1 As Document = app.OpenDocument(imgFolder, False) Try srcDoc = app.OpenDocument(srcFile, False) ' '延时(1000) Thread.Sleep(500) destDoc = app.OpenDocument(destFile, False) Thread.Sleep(500) srcLayer = srcDoc.Pages(1).Layers("Layer_1") destLayer = destDoc.Pages(1).Layers("Key_8") If destLayer Is Nothing Then destLayer = destDoc.Pages(1).Layers.Add("Key_8") End If For Each shp In srcLayer.Shapes 'If nn = 0 Then ' nn = nn + 1 ' Continue For 'End If If nn < 8 Then nn = nn + 1 '''Console.WriteLine(shp.Name) shp.Copy() shp = destLayer.Paste() For Each nshp In destLayer.Shapes If nshp.Name.Equals($"Kuan_{nn}") Then x = nshp.CenterX - shp.CenterX y = nshp.CenterY - shp.CenterY 'w = nshp.SizeWidth 'h = nshp.SizeHeight 'Dim st = destLayer.CreateArtisticText( ' x, y, ' "X=" & Format(x, "0.0") & vbCrLf & ' "Y=" & Format(y, "0.0") & vbCrLf & ' "W=" & Format(w, "0.0") & vbCrLf & ' "H=" & Format(h, "0.0")) 'st.Fill.UniformColor.CMYKAssign(0, 0, 0, 100) '黑色文字 dx = nshp.LeftX dy = nshp.TopY shp.Move(x, y) Thread.Sleep(500) End If Next nshp 'shp.MoveToLayer(,) Else Exit For End If Next shp destLayer.Shapes.All().Group() destDoc.SaveAs(srcFile1) srcDoc.Close() destDoc.Close() destDoc1 = app.OpenDocument(srcFile1, False) 'Dim opt As StructExportOptions = New StructExportOptions() 'opt.ImageType = cdrImageType.cdrDuotoneImage 'opt.JPEGQuality = 90 'opt.ResolutionX = 300 ' // 300 dpi 'opt.ResolutionY = 300 'opt.MaintainAspect = True 'opt.AntiAliasing = cdrAntiAliasingType.cdrNormalAntiAliasing srcFile1 = srcFile1.Replace(".cdr", ".png") '// 4) 导出 JPG Dim Ef As ExportFilter = destDoc1.ExportBitmap(srcFile1, VGCore.cdrFilter.cdrPNG) Ef.Finish() 'destDoc1.Close() Catch ex As Exception If srcDoc IsNot Nothing Then srcDoc.Close() If destDoc IsNot Nothing Then destDoc.Close() If destDoc1 IsNot Nothing Then destDoc1.Close() '''Console.WriteLine(ex.Message) End Try End Sub Private Sub ToolStripButton5_Click(sender As Object, e As EventArgs) Handles ToolStripButton5.Click '删除素材库 Try ' 3. 检查是否选择了素材库 If String.IsNullOrEmpty(ToolStripComboBox1.Text) Then MsgBox("请先选择要删除的素材库！", vbExclamation, "错误") Return End If ' 4. 获取选中的素材库名称 Dim selectedFileName As String = ToolStripComboBox1.Text ' 1. 显示密码输入对话框 Dim password As String = InputBox("请输入密码", $"即将删除：{vbCrLf}{selectedFileName}", "", -1, -1) ' 2. 验证密码 If password <> "123456" Then MsgBox("密码错误，删除失败！", vbExclamation, "错误") Return End If ' 5. 从字典中获取对应的ID If M_FileIdDict.ContainsKey(selectedFileName) Then Dim fileId As Integer = M_FileIdDict(selectedFileName) ' 6. 执行数据库删除操作 Dim npgsqldb As DbExecutor = New DbExecutor(DbExecutor.DbTypeEnum.Mysql, LocalConnString) Try npgsqldb.Open() ' 7. 开始事务 npgsqldb.BeginTransaction() ' 8. 根据素材库类型执行不同的删除逻辑 If selectedFileName.Contains("图标图库") Then ' 删除图标素材库相关数据 ' 删除tbl_iconlibrary中FID一致的数据 Dim deleteIconSql As String = $"DELETE FROM `cdr_library`.`tbl_iconlibrary` WHERE `FID` = {fileId};" npgsqldb.ExecuteNonQuery(deleteIconSql) ElseIf selectedFileName.Contains("模型图库") Then ' 删除模型素材库相关数据 ' 1. 处理tbl_model相关数据 ' 查询tbl_model中FID等于fileId的数据 Dim modelSql As String = $"SELECT `Id` FROM `cdr_library`.`tbl_model` WHERE `FID` = {fileId};" Dim modelDt As DataTable = npgsqldb.ExecuteDataTable(modelSql) ' 遍历tbl_model表得到的ID For Each modelRow As DataRow In modelDt.Rows Dim modelId As Integer = modelRow("Id") ' 删除tbl_trench中MID符合的数据 Dim deleteTrenchSql As String = $"DELETE FROM `cdr_library`.`tbl_trench` WHERE `MID` = {modelId};" npgsqldb.ExecuteNonQuery(deleteTrenchSql) ' 删除tbl_model中对应ID的数据 Dim deleteModelSql As String = $"DELETE FROM `cdr_library`.`tbl_model` WHERE `ID` = {modelId};" npgsqldb.ExecuteNonQuery(deleteModelSql) Next ' 2. 处理tbl_pattern相关数据 ' 查询tbl_pattern中FID等于fileId的数据 Dim patternSql As String = $"SELECT `Id` FROM `cdr_library`.`tbl_pattern` WHERE `FID` = {fileId};" Dim patternDt As DataTable = npgsqldb.ExecuteDataTable(patternSql) ' 遍历tbl_pattern表得到的ID For Each patternRow As DataRow In patternDt.Rows Dim patternId As Integer = patternRow("Id") ' 删除tbl_location中MID符合的数据 Dim deleteLocationSql As String = $"DELETE FROM `cdr_library`.`tbl_location` WHERE `PID` = {patternId};" npgsqldb.ExecuteNonQuery(deleteLocationSql) ' 删除tbl_pattern中对应ID的数据 Dim deletePatternSql As String = $"DELETE FROM `cdr_library`.`tbl_pattern` WHERE `ID` = {patternId};" npgsqldb.ExecuteNonQuery(deletePatternSql) Next End If ' 9. 删除tbl_cdr_file中对应id的数据 Dim deleteFileSql As String = $"DELETE FROM `cdr_library`.`tbl_cdr_file` WHERE `ID` = {fileId};" npgsqldb.ExecuteNonQuery(deleteFileSql) ' 10. 提交事务 npgsqldb.CommitTransaction() ' 11. 从下拉框中移除已删除的选项 ToolStripComboBox1.Items.Remove(selectedFileName) ' 12. 清空选择 ToolStripComboBox1.Text = "" ' 13. 显示成功消息 MsgBox("素材库删除成功！", vbInformation, "成功") Catch ex As Exception ' 14. 回滚事务 npgsqldb.RollbackTransaction() MsgBox($"删除失败：{ex.Message}", vbExclamation, "错误") Finally npgsqldb.Close() End Try Else MsgBox("未找到素材库对应的ID！", vbExclamation, "错误") End If Catch ex As Exception MsgBox($"操作失败：{ex.Message}", vbExclamation, "错误") End Try End Sub End Class